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 leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
 133               Default NullMaker columnsR nullableColumnsR,
 134               Default Unpackspec columnsR columnsR,
 135               Default Unpackspec nullableColumnsR nullableColumnsR,
 136               Default Unpackspec columnsL1 columnsL1,
 137               Default Unpackspec columnsL columnsL) =>
 138               Query columnsL1 -> Query columnsR -> Query columnsL
 139                 -> ((columnsL1, columnsR) -> Column PGBool)
 140                 -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
 141                 -> Query (columnsL, nullableColumnsR1)
 142 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
 143
 144
 145 leftJoin3' :: Query (NodeRead, (NodeReadNull, NodeNodeNgramReadNull))
 146 leftJoin3' = leftJoin3 queryNodeTable  queryNodeNodeNgramTable queryNodeTable cond12 cond23
 147     where
 148          cond12 (Node favId _ _ _ _ _ _, NodeNodeNgram favId' _ _ _)
 149                 = (.==) favId favId'
 150
 151          cond23 :: (NodeRead, (NodeRead, NodeNodeNgramReadNull)) -> Column PGBool
 152          cond23 (Node  docId _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ docId' _ _))
 153                 = (.||) ((.==) (toNullable docId) docId') (isNull docId')
 154
 155
 156 -- | Building the facet
 157 selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 158 selectDocFacet' parentId _ = proc () -> do
 159     node <- (proc () -> do
 160
 161             -- Favorite Column
 162             (Node _ favTypeId _ favParentId _ _ _)      <- queryNodeTable -< ()
 163             restrict -< favTypeId .== 15 .&& favParentId .== (toNullable $ pgInt4 parentId)
 164
 165             -- select nn.score from nodes n left join nodes_nodes nn on n.id = nn.node2_id where n.typename =4;
 166             -- Selecting the documents and joining Favorite Node
 167             (Node docId docTypeId _ docParentId _ created docHyperdata, NodeNode _ docTypeId' _) <- nodeNodeLeftJoin' (toNullable $ pgInt4 347537) -< ()
 168             restrict -< docParentId .== (toNullable $ pgInt4 parentId)
 169             let docTypeId'' = maybe 0 nodeTypeId (Just Document)
 170             restrict -< if docTypeId'' > 0
 171                            then docTypeId   .== (pgInt4 (docTypeId'' :: Int))
 172                            else (pgBool True)
 173
 174             -- Getting favorite data
 175             let isFav = ifThenElse (isNull docTypeId') (pgBool False) (pgBool True)
 176             -- Ngram count by document
 177             -- Counting the ngram
 178             -- (Node occId occTypeId _ _ _ _ _, NodeNode _ _ _ count) <- nodeNodeNgramLeftJoin -< ()
 179             -- restrict -< occId .== 347540
 180
 181             --returnA  -< (FacetDoc n_id hyperdata isFav ngramCount)) -< ()
 182             returnA  -< (FacetDoc docId created docHyperdata isFav)) -< ()
 183     returnA -< node
 184
 185