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 -- | DocFacet
  61 type FacetDoc = Facet NodeId UTCTime HyperdataDocument Bool Int
  62
  63 data Facet id created hyperdata favorite ngramCount =
  64      FacetDoc { facetDoc_id         :: id
  65                , facetDoc_created    :: created
  66                , facetDoc_hyperdata  :: hyperdata
  67                , facetDoc_favorite   :: favorite
  68                , facetDoc_ngramCount :: ngramCount
  69                } deriving (Show, Generic)
  70
  71 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
  72
  73 instance Arbitrary FacetDoc where
  74     arbitrary = elements [ FacetDoc id' (jour year 01 01) hp fav ngramCount
  75                          | id'  <- [1..10]
  76                          , year <- [1990..2000]
  77                          , hp   <- hyperdataDocuments
  78                          , fav  <- [True, False]
  79                          , ngramCount <- [3..100]
  80                          ]
  81
  82 -- Facets / Views for the Front End
  83 type FacetDocRead = Facet (Column PGInt4       )
  84                           (Column PGTimestamptz)
  85                           (Column PGJsonb      )
  86                           (Column PGBool       )
  87                           (Column PGInt4       )
  88
  89 instance ToSchema FacetDoc
  90
  91
  92 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
  93 $(makeLensesWith abbreviatedFields   ''Facet)
  94
  95 ------------------------------------------------------------------------
  96
  97
  98 getDocFacet :: Connection -> Int -> Maybe NodeType
  99             -> Maybe Offset -> Maybe Limit
 100             -> IO [FacetDoc]
 101 getDocFacet conn parentId nodeType maybeOffset maybeLimit =
 102     runQuery conn $ selectDocFacet parentId nodeType maybeOffset maybeLimit
 103
 104 selectDocFacet :: ParentId -> Maybe NodeType
 105                -> Maybe Offset -> Maybe Limit
 106                -> Query FacetDocRead
 107 selectDocFacet parentId maybeNodeType maybeOffset maybeLimit =
 108         limit' maybeLimit $ offset' maybeOffset
 109                           $ orderBy (asc facetDoc_created)
 110                           $ selectDocFacet' parentId maybeNodeType
 111
 112
 113 -- | Left join to the favorites
 114 nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
 115 nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
 116     where
 117         eqNode (Node n1 _ _ _ _ _ _, NodeNode _ n2 _) = ((.==) n1 n2)
 118
 119
 120 nodeNodeLeftJoin' :: (Column (Nullable PGInt4))
 121                   -> Query (NodeRead, NodeNodeReadNull)
 122 nodeNodeLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeTable (eqNode nId)
 123         where
 124             eqNode n (Node n1 _ _ _ _ _ _, NodeNode n1' n2 _)
 125                    = foldl (.&&) (pgBool True) [ ((.==) n1 n2)
 126                                                , ((.==) n1' n)
 127                                                ]
 128
 129 nodeNodeLeftJoin'' :: Query (NodeRead, NodeRead, NodeNodeRead)
 130 nodeNodeLeftJoin'' = join3 queryNodeTable queryNodeTable queryNodeNodeTable eqNode
 131         where
 132             eqNode (Node n1 _ _ _ _ _ _, Node n2 _ _ _ _ _ _, NodeNode n1' n2' _)
 133                    = foldl (.&&) (pgBool True) [ ((.==) n2 n2')
 134                                                , ((.==) (toNullable n1) n1')
 135                                                ]
 136
 137 -- | Left join to the ngram count per document
 138 nodeNodeNgramLeftJoin :: Query (NodeRead, NodeNodeNgramReadNull)
 139 nodeNodeNgramLeftJoin = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode)
 140      where
 141         eqNode (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' _ _ _) = ((.==) n1 n1')
 142
 143
 144 nodeNodeNgramLeftJoin' :: Column (Nullable PGInt4)
 145                        -> Query (NodeRead, NodeNodeNgramReadNull)
 146 nodeNodeNgramLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode nId)
 147      where
 148         eqNode nId' (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' n2 _ _)
 149                  = (.&&) ((.==) n1 n1')
 150                          ((.==) nId' (toNullable n2))
 151
 152
 153 leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
 154               Default NullMaker columnsR nullableColumnsR,
 155               Default Unpackspec columnsR columnsR,
 156               Default Unpackspec nullableColumnsR nullableColumnsR,
 157               Default Unpackspec columnsL1 columnsL1,
 158               Default Unpackspec columnsL columnsL) =>
 159               Query columnsL1 -> Query columnsR -> Query columnsL
 160                 -> ((columnsL1, columnsR) -> Column PGBool)
 161                 -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
 162                 -> Query (columnsL, nullableColumnsR1)
 163 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
 164
 165
 166 leftJoin3' :: Query (NodeRead, (NodeReadNull, NodeNodeNgramReadNull))
 167 leftJoin3' = leftJoin3 queryNodeTable  queryNodeNodeNgramTable queryNodeTable cond12 cond23
 168     where
 169          cond12 (Node occId _ _ _ _ _ _, NodeNodeNgram occId' _ _ _)
 170                 = (.==) occId occId'
 171
 172          cond23 :: (NodeRead, (NodeRead, NodeNodeNgramReadNull)) -> Column PGBool
 173          cond23 (Node  docId _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ docId' _ _))
 174                 = (.||) ((.==) (toNullable docId) docId') (isNull docId')
 175
 176
 177 leftJoin3''' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
 178 leftJoin3''' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
 179     where
 180          cond12 (NodeNode favId _ _, Node favId' _ _ _ _ _ _)
 181                 = (.||) ((.==) favId (toNullable favId')) (isNull $ toNullable favId)
 182
 183          cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
 184          cond23 (Node  nId _ _ _ _ _ _, (NodeNode _ nId' _, Node _ _ _ _ _ _ _ ))
 185                 = ((.==) (nId) (nId'))
 186
 187
 188 -- getDocTest :: Connection -> IO [FacetDoc]
 189 -- getDocTest conn = runQuery conn selectDocFacet
 190
 191 -- | Building the facet
 192 -- selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 193 selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 194 selectDocFacet' _ _ = proc () -> do
 195         (n1,(nn,n2)) <- leftJoin3''' -< ()
 196         restrict -< (.&&) (node_parentId n1 .== (toNullable $ pgInt4 347476))
 197                           (node_typename n1 .== (pgInt4 4))
 198
 199         restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 15))
 200                           (isNull $ node_typename n2)
 201
 202         restrict -< (.||) (node_parentId n2 .== (toNullable $ pgInt4 347476))
 203                           (isNull $ node_parentId n2)
 204
 205         let isFav = ifThenElse (isNull $ nodeNode_score nn) (pgBool False) (pgBool True)
 206 --
 207         returnA  -< FacetDoc (node_id n1) (node_date n1) (node_hyperdata n1) (isFav) (pgInt4 1)
 208
 209