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, timesAfter, Granularity(D))
  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 type UTCTime' = UTCTime
 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 UTCTime' where
 123     arbitrary = elements $ timesAfter 100 D (jour 2000 01 01)
 124
 125 instance Arbitrary FacetChart where
 126     arbitrary = FacetChart <$> arbitrary <*> arbitrary
 127
 128 -----------------------------------------------------------------------
 129
 130
 131 getDocFacet :: Connection -> Int -> Maybe NodeType
 132             -> Maybe Offset -> Maybe Limit
 133             -> IO [FacetDoc]
 134 getDocFacet conn parentId nodeType maybeOffset maybeLimit =
 135     runQuery conn $ selectDocFacet parentId nodeType maybeOffset maybeLimit
 136
 137 selectDocFacet :: ParentId -> Maybe NodeType
 138                -> Maybe Offset -> Maybe Limit
 139                -> Query FacetDocRead
 140 selectDocFacet parentId maybeNodeType maybeOffset maybeLimit =
 141         limit' maybeLimit $ offset' maybeOffset
 142                           $ orderBy (asc facetDoc_created)
 143                           $ selectDocFacet' parentId maybeNodeType
 144
 145
 146 -- | Left join to the favorites
 147 nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
 148 nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
 149     where
 150         eqNode (Node n1 _ _ _ _ _ _, NodeNode _ n2 _) = ((.==) n1 n2)
 151
 152
 153 nodeNodeLeftJoin' :: (Column (Nullable PGInt4))
 154                   -> Query (NodeRead, NodeNodeReadNull)
 155 nodeNodeLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeTable (eqNode nId)
 156         where
 157             eqNode n (Node n1 _ _ _ _ _ _, NodeNode n1' n2 _)
 158                    = foldl (.&&) (pgBool True) [ ((.==) n1 n2)
 159                                                , ((.==) n1' n)
 160                                                ]
 161
 162 nodeNodeLeftJoin'' :: Query (NodeRead, NodeRead, NodeNodeRead)
 163 nodeNodeLeftJoin'' = join3 queryNodeTable queryNodeTable queryNodeNodeTable eqNode
 164         where
 165             eqNode (Node n1 _ _ _ _ _ _, Node n2 _ _ _ _ _ _, NodeNode n1' n2' _)
 166                    = foldl (.&&) (pgBool True) [ ((.==) n2 n2')
 167                                                , ((.==) (toNullable n1) n1')
 168                                                ]
 169
 170 -- | Left join to the ngram count per document
 171 nodeNodeNgramLeftJoin :: Query (NodeRead, NodeNodeNgramReadNull)
 172 nodeNodeNgramLeftJoin = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode)
 173      where
 174         eqNode (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' _ _ _) = ((.==) n1 n1')
 175
 176
 177 nodeNodeNgramLeftJoin' :: Column (Nullable PGInt4)
 178                        -> Query (NodeRead, NodeNodeNgramReadNull)
 179 nodeNodeNgramLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode nId)
 180      where
 181         eqNode nId' (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' n2 _ _)
 182                  = (.&&) ((.==) n1 n1')
 183                          ((.==) nId' (toNullable n2))
 184
 185
 186 leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
 187               Default NullMaker columnsR nullableColumnsR,
 188               Default Unpackspec columnsR columnsR,
 189               Default Unpackspec nullableColumnsR nullableColumnsR,
 190               Default Unpackspec columnsL1 columnsL1,
 191               Default Unpackspec columnsL columnsL) =>
 192               Query columnsL1 -> Query columnsR -> Query columnsL
 193                 -> ((columnsL1, columnsR) -> Column PGBool)
 194                 -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
 195                 -> Query (columnsL, nullableColumnsR1)
 196 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
 197
 198
 199 leftJoin3' :: Query (NodeRead, (NodeReadNull, NodeNodeNgramReadNull))
 200 leftJoin3' = leftJoin3 queryNodeTable  queryNodeNodeNgramTable queryNodeTable cond12 cond23
 201     where
 202          cond12 (Node occId _ _ _ _ _ _, NodeNodeNgram occId' _ _ _)
 203                 = (.==) occId occId'
 204
 205          cond23 :: (NodeRead, (NodeRead, NodeNodeNgramReadNull)) -> Column PGBool
 206          cond23 (Node  docId _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ docId' _ _))
 207                 = (.||) ((.==) (toNullable docId) docId') (isNull docId')
 208
 209
 210 leftJoin3''' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
 211 leftJoin3''' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
 212     where
 213          cond12 (NodeNode favId _ _, Node favId' _ _ _ _ _ _)
 214                 = (.||) ((.==) favId (toNullable favId')) (isNull $ toNullable favId)
 215
 216          cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
 217          cond23 (Node  nId _ _ _ _ _ _, (NodeNode _ nId' _, Node _ _ _ _ _ _ _ ))
 218                 = ((.==) (nId) (nId'))
 219
 220
 221 -- getDocTest :: Connection -> IO [FacetDoc]
 222 -- getDocTest conn = runQuery conn selectDocFacet
 223
 224 -- | Building the facet
 225 -- selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 226 selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 227 selectDocFacet' _ _ = proc () -> do
 228         (n1,(nn,n2)) <- leftJoin3''' -< ()
 229         restrict -< (.&&) (node_parentId n1 .== (toNullable $ pgInt4 347476))
 230                           (node_typename n1 .== (pgInt4 4))
 231
 232         restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 15))
 233                           (isNull $ node_typename n2)
 234
 235         restrict -< (.||) (node_parentId n2 .== (toNullable $ pgInt4 347476))
 236                           (isNull $ node_parentId n2)
 237
 238         let isFav = ifThenElse (isNull $ nodeNode_score nn) (pgBool False) (pgBool True)
 239 --
 240         returnA  -< FacetDoc (node_id n1) (node_date n1) (node_hyperdata n1) (isFav) (pgInt4 1)
 241
 242