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 FlexibleContexts          #-}
  17 {-# LANGUAGE FlexibleInstances         #-}
  18 {-# LANGUAGE FunctionalDependencies    #-}
  19 {-# LANGUAGE MultiParamTypeClasses     #-}
  20 {-# LANGUAGE NoImplicitPrelude         #-}
  21 {-# LANGUAGE NoMonomorphismRestriction #-}
  22 {-# LANGUAGE TemplateHaskell           #-}
  23
  24 ------------------------------------------------------------------------
  25 module Gargantext.Database.Facet
  26   where
  27 ------------------------------------------------------------------------
  28
  29 import Prelude hiding (null, id, map, sum, not)
  30 import GHC.Generics (Generic)
  31
  32 -- import Data.Aeson (Value)
  33 import Control.Arrow (returnA)
  34 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  35
  36 import Data.Aeson.TH (deriveJSON)
  37 import Data.Maybe (Maybe)
  38 import Data.Profunctor.Product.Default (Default)
  39 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  40 import Data.Time (UTCTime)
  41 import Data.Time.Segment (jour)
  42 import Data.Swagger
  43
  44 import           Database.PostgreSQL.Simple (Connection)
  45 import           Opaleye
  46 import           Opaleye.Internal.Join (NullMaker)
  47 import qualified Opaleye.Internal.Unpackspec()
  48
  49 import Test.QuickCheck.Arbitrary
  50 import Test.QuickCheck (elements)
  51
  52 import Gargantext.Core.Types
  53 import Gargantext.Database.Types.Node (NodeType)
  54 import Gargantext.Core.Utils.Prefix (unPrefix)
  55 import Gargantext.Database.NodeNode
  56 import Gargantext.Database.NodeNodeNgram
  57 import Gargantext.Database.Node
  58 import Gargantext.Database.Queries
  59 import Gargantext.Database.Config (nodeTypeId)
  60 -- import Gargantext.Database.NodeNgram
  61
  62 ------------------------------------------------------------------------
  63 -- | DocFacet
  64
  65 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
  66 --    deriving (Show, Generic)
  67 --instance FromJSON Facet
  68 --instance ToJSON   Facet
  69
  70 type FacetDoc = Facet NodeId UTCTime HyperdataDocument Bool Int
  71 type FacetSources = FacetDoc
  72 type FacetAuthors = FacetDoc
  73 type FacetTerms   = FacetDoc
  74
  75
  76
  77 data Facet id created hyperdata favorite ngramCount =
  78      FacetDoc { facetDoc_id         :: id
  79                , facetDoc_created    :: created
  80                , facetDoc_hyperdata  :: hyperdata
  81                , facetDoc_favorite   :: favorite
  82                , facetDoc_ngramCount :: ngramCount
  83                } deriving (Show, Generic)
  84
  85 -- | JSON instance
  86
  87 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
  88
  89 -- | Documentation instance
  90 instance ToSchema FacetDoc
  91
  92 -- | Mock and Quickcheck instances
  93
  94 instance Arbitrary FacetDoc where
  95     arbitrary = elements [ FacetDoc id' (jour year 01 01) hp fav ngramCount
  96                          | id'  <- [1..10]
  97                          , year <- [1990..2000]
  98                          , hp   <- hyperdataDocuments
  99                          , fav  <- [True, False]
 100                          , ngramCount <- [3..100]
 101                          ]
 102
 103 -- Facets / Views for the Front End
 104 -- | Database instances
 105 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
 106 $(makeLensesWith abbreviatedFields   ''Facet)
 107
 108 type FacetDocRead = Facet (Column PGInt4       )
 109                           (Column PGTimestamptz)
 110                           (Column PGJsonb      )
 111                           (Column PGBool       )
 112                           (Column PGInt4       )
 113
 114 -----------------------------------------------------------------------
 115
 116 data FacetChart = FacetChart { facetChart_time  :: UTCTime'
 117                              , facetChart_count :: Double
 118                         }
 119         deriving (Show, Generic)
 120 $(deriveJSON (unPrefix "facetChart_") ''FacetChart)
 121 instance ToSchema FacetChart
 122
 123 instance Arbitrary FacetChart where
 124     arbitrary = FacetChart <$> arbitrary <*> arbitrary
 125
 126 -----------------------------------------------------------------------
 127
 128
 129 getDocFacet :: Connection -> NodeType -> Int -> Maybe NodeType
 130             -> Maybe Offset -> Maybe Limit
 131             -> IO [FacetDoc]
 132 getDocFacet conn parentType parentId nodeType maybeOffset maybeLimit =
 133     runQuery conn $ selectDocFacet parentType parentId nodeType maybeOffset maybeLimit
 134
 135 selectDocFacet :: NodeType -> ParentId -> Maybe NodeType
 136                -> Maybe Offset -> Maybe Limit
 137                -> Query FacetDocRead
 138 selectDocFacet pType parentId maybeNodeType maybeOffset maybeLimit =
 139         limit' maybeLimit $ offset' maybeOffset
 140                           $ orderBy (asc facetDoc_created)
 141                           $ selectDocFacet' pType parentId maybeNodeType
 142
 143
 144 -- | Left join to the favorites
 145 nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
 146 nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
 147     where
 148         eqNode (Node n1 _ _ _ _ _ _, NodeNode _ n2 _) = ((.==) n1 n2)
 149
 150
 151 nodeNodeLeftJoin' :: (Column (Nullable PGInt4))
 152                   -> Query (NodeRead, NodeNodeReadNull)
 153 nodeNodeLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeTable (eqNode nId)
 154         where
 155             eqNode n (Node n1 _ _ _ _ _ _, NodeNode n1' n2 _)
 156                    = foldl (.&&) (pgBool True) [ ((.==) n1 n2)
 157                                                , ((.==) n1' n)
 158                                                ]
 159
 160 nodeNodeLeftJoin'' :: Query (NodeRead, NodeRead, NodeNodeRead)
 161 nodeNodeLeftJoin'' = join3 queryNodeTable queryNodeTable queryNodeNodeTable eqNode
 162         where
 163             eqNode (Node n1 _ _ _ _ _ _, Node n2 _ _ _ _ _ _, NodeNode n1' n2' _)
 164                    = foldl (.&&) (pgBool True) [ ((.==) n2 n2')
 165                                                , ((.==) (toNullable n1) n1')
 166                                                ]
 167
 168 -- | Left join to the ngram count per document
 169 nodeNodeNgramLeftJoin :: Query (NodeRead, NodeNodeNgramReadNull)
 170 nodeNodeNgramLeftJoin = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode)
 171      where
 172         eqNode (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' _ _ _) = ((.==) n1 n1')
 173
 174
 175 nodeNodeNgramLeftJoin' :: Column (Nullable PGInt4)
 176                        -> Query (NodeRead, NodeNodeNgramReadNull)
 177 nodeNodeNgramLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode nId)
 178      where
 179         eqNode nId' (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' n2 _ _)
 180                  = (.&&) ((.==) n1 n1')
 181                          ((.==) nId' (toNullable n2))
 182
 183
 184 leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
 185               Default NullMaker columnsR nullableColumnsR,
 186               Default Unpackspec columnsR columnsR,
 187               Default Unpackspec nullableColumnsR nullableColumnsR,
 188               Default Unpackspec columnsL1 columnsL1,
 189               Default Unpackspec columnsL columnsL) =>
 190               Query columnsL1 -> Query columnsR -> Query columnsL
 191                 -> ((columnsL1, columnsR) -> Column PGBool)
 192                 -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
 193                 -> Query (columnsL, nullableColumnsR1)
 194 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
 195
 196
 197 leftJoin3' :: Query (NodeRead, (NodeReadNull, NodeNodeNgramReadNull))
 198 leftJoin3' = leftJoin3 queryNodeTable  queryNodeNodeNgramTable queryNodeTable cond12 cond23
 199     where
 200          cond12 (Node occId _ _ _ _ _ _, NodeNodeNgram occId' _ _ _)
 201                 = (.==) occId occId'
 202
 203          cond23 :: (NodeRead, (NodeRead, NodeNodeNgramReadNull)) -> Column PGBool
 204          cond23 (Node  docId _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ docId' _ _))
 205                 = (.||) ((.==) (toNullable docId) docId') (isNull docId')
 206
 207
 208 leftJoin3''' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
 209 leftJoin3''' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
 210     where
 211          cond12 (NodeNode favId _ _, Node favId' _ _ _ _ _ _)
 212                 = (.||) ((.==) favId (toNullable favId')) (isNull $ toNullable favId)
 213
 214          cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
 215          cond23 (Node  nId _ _ _ _ _ _, (NodeNode _ nId' _, Node _ _ _ _ _ _ _ ))
 216                 = ((.==) (nId) (nId'))
 217
 218
 219 -- | Building the facet
 220 selectDocFacet' :: NodeType -> ParentId -> Maybe NodeType -> Query FacetDocRead
 221 selectDocFacet' _ pId _ = proc () -> do
 222         (n1,(nn,n2)) <- leftJoin3''' -< ()
 223         restrict -< (.&&) (node_parentId n1 .== (toNullable $ pgInt4 pId))
 224                           (node_typename n1 .== (pgInt4 $ nodeTypeId Document))
 225
 226         restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 $ nodeTypeId Favorites))
 227                           (isNull $ node_typename n2)
 228
 229         restrict -< (.||) (node_parentId n2 .== (toNullable $ pgInt4 $ nodeTypeId Favorites))
 230                           (isNull $ node_parentId n2)
 231
 232         let isFav = ifThenElse (isNull $ nodeNode_score nn) (pgBool False) (pgBool True)
 233
 234         returnA  -< FacetDoc (node_id n1) (node_date n1) (node_hyperdata n1) (isFav) (pgInt4 1)
 235
 236