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