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-name-shadowing #-}
  12 {-# LANGUAGE TemplateHaskell #-}
  13 {-# LANGUAGE FlexibleInstances #-}
  14 {-# LANGUAGE FlexibleContexts #-}
  15 {-# LANGUAGE DeriveGeneric #-}
  16 {-# LANGUAGE MultiParamTypeClasses #-}
  17 {-# LANGUAGE FunctionalDependencies #-}
  18 {-# LANGUAGE Arrows #-}
  19 {-# OPTIONS_GHC -fno-warn-orphans #-}
  20
  21 module Gargantext.Database.Facet where
  22
  23 import Prelude hiding (null, id, map, sum, not)
  24
  25 import Gargantext.Types
  26 import Gargantext.Types.Node (NodeType)
  27 import Gargantext.Database.NodeNode
  28 import Gargantext.Database.NodeNodeNgram
  29 import Gargantext.Database.Node
  30 import Gargantext.Database.Queries
  31 import Gargantext.Utils.Prefix (unPrefix)
  32 -- import Gargantext.Database.NodeNgram
  33
  34 -- import Data.Aeson (Value)
  35 import Data.Aeson.TH (deriveJSON)
  36 import Control.Arrow (returnA)
  37 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  38 import Data.Maybe (Maybe)
  39 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  40 import Data.Time (UTCTime)
  41 import Database.PostgreSQL.Simple (Connection)
  42 import Opaleye
  43 import Opaleye.Internal.Join (NullMaker)
  44
  45 import qualified Opaleye.Internal.Unpackspec()
  46 import Data.Profunctor.Product.Default (Default)
  47
  48 import Data.Time.Segment (jour)
  49
  50 import Test.QuickCheck.Arbitrary
  51 import Test.QuickCheck (elements)
  52
  53
  54 -- DocFacet
  55
  56 type FacetDoc = Facet NodeId UTCTime HyperdataDocument Bool -- Double
  57
  58 data Facet id created hyperdata favorite  = FacetDoc { facetDoc_id :: id
  59                                                        , facetDoc_created   :: created
  60                                                        , facetDoc_hyperdata :: hyperdata
  61                                                        , facetDoc_favorite  :: favorite
  62                                           -- To be added: Double
  63                                           --             , facetDoc_ngramCount :: ngramCount
  64                                                        } deriving (Show)
  65 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
  66
  67 instance Arbitrary FacetDoc where
  68     arbitrary = elements [ FacetDoc id' (jour year 01 01) hp fav
  69                          | id'  <- [1..10]
  70                          , year <- [1990..2000]
  71                          , fav  <- [True, False]
  72                          , hp   <- hyperdataDocuments
  73                          ]
  74
  75 -- Facets / Views for the Front End
  76 type FacetDocRead  = Facet (Column PGInt4) (Column PGTimestamptz) (Column PGJsonb) (Column PGBool) -- (Column PGFloat8)
  77
  78 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
  79 $(makeLensesWith abbreviatedFields   ''Facet)
  80
  81 getDocFacet :: Connection -> Int -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> IO [FacetDoc]
  82 getDocFacet conn parentId nodeType maybeOffset maybeLimit =
  83     runQuery conn $ selectDocFacet parentId nodeType maybeOffset maybeLimit
  84
  85 selectDocFacet :: ParentId -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> Query FacetDocRead
  86 selectDocFacet parentId maybeNodeType maybeOffset maybeLimit =
  87         limit' maybeLimit $ offset' maybeOffset $ orderBy (asc facetDoc_created) $ selectDocFacet' parentId maybeNodeType
  88
  89
  90 -- | Left join to the favorites
  91 nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
  92 nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
  93     where
  94         eqNode (Node n1 _ _ _ _ _ _, NodeNode _ n2 _) = ((.==) n1 n2)
  95
  96
  97 nodeNodeLeftJoin' :: (Column (Nullable PGInt4))
  98                   -> Query (NodeRead, NodeNodeReadNull)
  99 nodeNodeLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeTable (eqNode nId)
 100         where
 101             eqNode n (Node n1 _ _ _ _ _ _, NodeNode n1' n2 _)
 102                    = foldl (.&&) (pgBool True) [ ((.==) n1 n2)
 103                                                , ((.==) n1' n)
 104                                                ]
 105
 106 nodeNodeLeftJoin'' :: Query (NodeRead, NodeRead, NodeNodeRead)
 107 nodeNodeLeftJoin'' = join3 queryNodeTable queryNodeTable queryNodeNodeTable eqNode
 108         where
 109             eqNode (Node n1 _ _ _ _ _ _, Node n2 _ _ _ _ _ _, NodeNode n1' n2' _)
 110                    = foldl (.&&) (pgBool True) [ ((.==) n2 n2')
 111                                                , ((.==) (toNullable n1) n1')
 112                                                ]
 113
 114 -- | Left join to the ngram count per document
 115 nodeNodeNgramLeftJoin :: Query (NodeRead, NodeNodeNgramReadNull)
 116 nodeNodeNgramLeftJoin = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode)
 117      where
 118         eqNode (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' _ _ _) = ((.==) n1 n1')
 119
 120
 121 nodeNodeNgramLeftJoin' :: Column (Nullable PGInt4)
 122                        -> Query (NodeRead, NodeNodeNgramReadNull)
 123 nodeNodeNgramLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode nId)
 124      where
 125         eqNode nId' (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' n2 _ _)
 126                  = (.&&) ((.==) n1 n1')
 127                          ((.==) nId' (toNullable n2))
 128
 129
 130 leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
 131               Default NullMaker columnsR nullableColumnsR,
 132               Default Unpackspec columnsR columnsR,
 133               Default Unpackspec nullableColumnsR nullableColumnsR,
 134               Default Unpackspec columnsL1 columnsL1,
 135               Default Unpackspec columnsL columnsL) =>
 136               Query columnsL1 -> Query columnsR -> Query columnsL
 137                 -> ((columnsL1, columnsR) -> Column PGBool)
 138                 -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
 139                 -> Query (columnsL, nullableColumnsR1)
 140 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
 141
 142
 143 --leftJoin3' :: Query (NodeRead, NodeNodeNgramReadNull)
 144 --leftJoin3' = leftJoin3 queryNodeTable  queryNodeNodeNgramTable queryNodeTable cond12 cond23
 145 --    where
 146 --         cond12 (Node _ _ _ _ _ _ _, NodeNodeNgram _ _ _ _)
 147 --                 = pgBool True
 148 --
 149 --         cond23 (Node _ _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ _ _ _))
 150 --                 = pgBool True
 151
 152
 153
 154 -- | Building the facet
 155 selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 156 selectDocFacet' parentId _ = proc () -> do
 157     node <- (proc () -> do
 158
 159             -- Favorite Column
 160             (Node _ favTypeId _ favParentId _ _ _)      <- queryNodeTable -< ()
 161             restrict -< favTypeId .== 15 .&& favParentId .== (toNullable $ pgInt4 parentId)
 162
 163             -- select nn.score from nodes n left join nodes_nodes nn on n.id = nn.node2_id where n.typename =4;
 164             -- Selecting the documents and joining Favorite Node
 165             (Node docId docTypeId _ docParentId _ created docHyperdata, NodeNode _ docTypeId' _) <- nodeNodeLeftJoin' (toNullable $ pgInt4 347537) -< ()
 166             restrict -< docParentId .== (toNullable $ pgInt4 parentId)
 167             let docTypeId'' = maybe 0 nodeTypeId (Just Document)
 168             restrict -< if docTypeId'' > 0
 169                            then docTypeId   .== (pgInt4 (docTypeId'' :: Int))
 170                            else (pgBool True)
 171
 172             -- Getting favorite data
 173             let isFav = ifThenElse (isNull docTypeId') (pgBool False) (pgBool True)
 174             -- Ngram count by document
 175             -- Counting the ngram
 176             -- (Node occId occTypeId _ _ _ _ _, NodeNode _ _ _ count) <- nodeNodeNgramLeftJoin -< ()
 177             -- restrict -< occId .== 347540
 178
 179             --returnA  -< (FacetDoc n_id hyperdata isFav ngramCount)) -< ()
 180             returnA  -< (FacetDoc docId created docHyperdata isFav)) -< ()
 181     returnA -< node
 182
 183