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