src/Gargantext/Database/Query/Facet.hs

   1 {-|
   2 Module      : Gargantext.Database.Query.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
  13 {-# LANGUAGE Arrows                    #-}
  14 {-# LANGUAGE FunctionalDependencies    #-}
  15 {-# LANGUAGE QuasiQuotes               #-}
  16 {-# LANGUAGE NoMonomorphismRestriction #-}
  17 {-# LANGUAGE TemplateHaskell           #-}
  18 {-# LANGUAGE TypeFamilies              #-}
  19 ------------------------------------------------------------------------
  20 module Gargantext.Database.Query.Facet
  21   ( runViewAuthorsDoc
  22   , runViewDocuments
  23 --   , viewDocuments'
  24   , runCountDocuments
  25   , filterWith
  26
  27   , Category
  28   , Score
  29   , Title
  30
  31   , Pair(..)
  32   , Facet(..)
  33   , FacetDoc
  34   , FacetDocRead
  35   , FacetPaired(..)
  36   , FacetPairedRead
  37   , FacetPairedReadNull
  38   , FacetPairedReadNullAgg
  39   , OrderBy(..)
  40   )
  41   where
  42
  43 import Control.Arrow (returnA, (>>>))
  44 import Control.Lens ((^.))
  45 import Data.Aeson (FromJSON, ToJSON)
  46 import Data.Aeson.TH (deriveJSON)
  47 --import qualified Database.PostgreSQL.Simple as DPS
  48 --import Database.PostgreSQL.Simple.SqlQQ (sql)
  49 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  50 import Data.Swagger
  51 import qualified Data.Text as T
  52 import Data.Time (UTCTime)
  53 import Data.Time.Segment (jour)
  54 import Opaleye
  55 import Protolude hiding (null, map, sum, not)
  56 import Servant.API
  57 import Test.QuickCheck (elements)
  58 import Test.QuickCheck.Arbitrary
  59 import qualified Opaleye.Internal.Unpackspec()
  60
  61 import Gargantext.Core
  62 import Gargantext.Core.Types
  63 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
  64 -- import Gargantext.Database.Action.TSQuery (toTSQuery)
  65 import Gargantext.Database.Admin.Types.Hyperdata
  66 import Gargantext.Database.Query.Filter
  67 import Gargantext.Database.Query.Join (leftJoin5)
  68 import Gargantext.Database.Query.Table.Ngrams
  69 import Gargantext.Database.Query.Table.Context
  70 import Gargantext.Database.Schema.Context
  71 import Gargantext.Database.Query.Table.NodeContext
  72 import Gargantext.Database.Query.Table.ContextNodeNgrams
  73 import Gargantext.Database.Prelude
  74 import Gargantext.Database.Schema.Node
  75 import Gargantext.Prelude (printDebug)
  76
  77 ------------------------------------------------------------------------
  78 -- | DocFacet
  79
  80 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
  81 --    deriving (Show, Generic)
  82 --instance FromJSON Facet
  83 --instance ToJSON   Facet
  84
  85 type Category = Int
  86 type Score    = Double
  87 type Title    = Text
  88
  89 -- TODO remove Title
  90 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Category) (Maybe Double) (Maybe Score)
  91 -- type FacetSources = FacetDoc
  92 -- type FacetAuthors = FacetDoc
  93 -- type FacetTerms   = FacetDoc
  94
  95
  96 data Facet id created title hyperdata category ngramCount score =
  97      FacetDoc { facetDoc_id         :: id
  98               , facetDoc_created    :: created
  99               , facetDoc_title      :: title
 100               , facetDoc_hyperdata  :: hyperdata
 101               , facetDoc_category   :: category
 102               , facetDoc_ngramCount :: ngramCount
 103               , facetDoc_score      :: score
 104               } deriving (Show, Generic)
 105 {- | TODO after demo
 106 data Facet id date hyperdata score =
 107      FacetDoc { facetDoc_id        :: id
 108               , facetDoc_date      :: date
 109               , facetDoc_hyperdata :: hyperdata
 110               , facetDoc_score     :: score
 111               } deriving (Show, Generic)
 112 -}
 113
 114 data Pair i l = Pair {
 115     _p_id    :: i
 116   , _p_label :: l
 117   } deriving (Show, Generic)
 118 $(deriveJSON (unPrefix "_p_") ''Pair)
 119 $(makeAdaptorAndInstance "pPair" ''Pair)
 120
 121 instance (Typeable i, Typeable l, ToSchema i, ToSchema l) => ToSchema (Pair i l) where
 122   declareNamedSchema = wellNamedSchema "_p_"
 123 instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
 124   arbitrary = Pair <$> arbitrary <*> arbitrary
 125
 126 data FacetPaired id date hyperdata score =
 127   FacetPaired { _fp_id        :: id
 128               , _fp_date      :: date
 129               , _fp_hyperdata :: hyperdata
 130               , _fp_score     :: score }
 131   deriving (Show, Generic)
 132 $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
 133 $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
 134
 135
 136
 137 instance ( ToSchema id
 138          , ToSchema date
 139          , ToSchema hyperdata
 140          , ToSchema score
 141          , Typeable id
 142          , Typeable date
 143          , Typeable hyperdata
 144          , Typeable score
 145          ) => ToSchema (FacetPaired id date hyperdata score) where
 146   declareNamedSchema = wellNamedSchema "_fp_"
 147
 148 instance ( Arbitrary id
 149          , Arbitrary date
 150          , Arbitrary hyperdata
 151          , Arbitrary score
 152          ) => Arbitrary (FacetPaired id date hyperdata score) where
 153   arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 154
 155 type FacetPairedRead = FacetPaired (Column SqlInt4       )
 156                                    (Column SqlTimestamptz)
 157                                    (Column SqlJsonb      )
 158                                    (Column SqlInt4       )
 159
 160 type FacetPairedReadNull = FacetPaired (Column (Nullable SqlInt4)       )
 161                                        (Column (Nullable SqlTimestamptz))
 162                                        (Column (Nullable SqlJsonb)      )
 163                                        (Column (Nullable SqlInt4)       )
 164
 165 type FacetPairedReadNullAgg = FacetPaired (Aggregator (Column (Nullable SqlInt4)       )
 166                                                       (Column (Nullable SqlInt4)       )
 167                                           )
 168                                           (Aggregator (Column (Nullable SqlTimestamptz))
 169                                                       (Column (Nullable SqlTimestamptz))
 170
 171                                           )
 172                                           (Aggregator (Column (Nullable SqlJsonb)      )
 173                                                       (Column (Nullable SqlJsonb)      )
 174                                           )
 175                                           (Aggregator (Column (Nullable SqlInt4)       )
 176                                                       (Column (Nullable SqlInt4)       )
 177                                           )
 178
 179
 180
 181
 182 -- | JSON instance
 183 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
 184
 185 -- | Documentation instance
 186 instance ToSchema FacetDoc where
 187   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "facetDoc_")
 188
 189 -- | Mock and Quickcheck instances
 190 instance Arbitrary FacetDoc where
 191     arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp (Just cat) (Just ngramCount) (Just score)
 192                          | id'        <- [1..10]
 193                          , year       <- [1990..2000]
 194                          , t          <- ["title", "another title"]
 195                          , hp         <- arbitraryHyperdataDocuments
 196                          , cat        <- [0..2]
 197                          , ngramCount <- [3..100]
 198                          , score      <- [3..100]
 199                          ]
 200
 201 -- Facets / Views for the Front End
 202 -- | Database instances
 203 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
 204 -- $(makeLensesWith abbreviatedFields   ''Facet)
 205
 206 type FacetDocRead = Facet (Column SqlInt4       )
 207                           (Column SqlTimestamptz)
 208                           (Column SqlText       )
 209                           (Column SqlJsonb      )
 210                           (Column (Nullable SqlInt4)) -- Category
 211                           (Column (Nullable SqlFloat8)) -- Ngrams Count
 212                           (Column (Nullable SqlFloat8)) -- Score
 213
 214 -----------------------------------------------------------------------
 215 -----------------------------------------------------------------------
 216 data OrderBy =  DateAsc   | DateDesc
 217              | TitleAsc   | TitleDesc
 218              | ScoreDesc  | ScoreAsc
 219              | SourceAsc  | SourceDesc
 220              deriving (Generic, Enum, Bounded, Read, Show)
 221
 222 instance FromHttpApiData OrderBy
 223   where
 224     parseUrlPiece "DateAsc"    = pure DateAsc
 225     parseUrlPiece "DateDesc"   = pure DateDesc
 226     parseUrlPiece "TitleAsc"   = pure TitleAsc
 227     parseUrlPiece "TitleDesc"  = pure TitleDesc
 228     parseUrlPiece "ScoreAsc"   = pure ScoreAsc
 229     parseUrlPiece "ScoreDesc"  = pure ScoreDesc
 230     parseUrlPiece "SourceAsc"  = pure SourceAsc
 231     parseUrlPiece "SourceDesc" = pure SourceDesc
 232     parseUrlPiece _            = Left "Unexpected value of OrderBy"
 233 instance ToHttpApiData OrderBy where
 234   toUrlPiece = T.pack . show
 235
 236 instance ToParamSchema OrderBy
 237 instance FromJSON  OrderBy
 238 instance ToJSON    OrderBy
 239 instance ToSchema  OrderBy
 240 instance Arbitrary OrderBy
 241   where
 242     arbitrary = elements [minBound..maxBound]
 243
 244
 245 -- TODO-SECURITY check
 246 runViewAuthorsDoc :: HasDBid NodeType
 247                   => ContactId
 248                   -> IsTrash
 249                   -> Maybe Offset
 250                   -> Maybe Limit
 251                   -> Maybe OrderBy
 252                   -> Cmd err [FacetDoc]
 253 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
 254   where
 255     ntId = NodeDocument
 256
 257 -- TODO add delete ?
 258 viewAuthorsDoc :: HasDBid NodeType
 259                => ContactId
 260                -> IsTrash
 261                -> NodeType
 262                -> Select FacetDocRead
 263 viewAuthorsDoc cId _ nt = proc () -> do
 264   (doc,(_,(_,(_,contact')))) <- queryAuthorsDoc      -< ()
 265
 266   restrict -< _node_id   contact'  .== (toNullable $ pgNodeId cId)
 267   restrict -< _node_typename doc   .== (sqlInt4 $ toDBid nt)
 268
 269   returnA  -< FacetDoc { facetDoc_id         = _node_id        doc
 270                        , facetDoc_created    = _node_date      doc
 271                        , facetDoc_title      = _node_name      doc
 272                        , facetDoc_hyperdata  = _node_hyperdata doc
 273                        , facetDoc_category   = toNullable $ sqlInt4 1
 274                        , facetDoc_ngramCount = toNullable $ sqlDouble 1
 275                        , facetDoc_score      = toNullable $ sqlDouble 1 }
 276
 277 queryAuthorsDoc :: Select (NodeRead, (ContextNodeNgramsReadNull, (NgramsReadNull, (ContextNodeNgramsReadNull, NodeReadNull))))
 278 queryAuthorsDoc = leftJoin5 queryNodeTable queryContextNodeNgramsTable queryNgramsTable queryContextNodeNgramsTable queryNodeTable cond12 cond23 cond34 cond45
 279     where
 280          cond12 :: (ContextNodeNgramsRead, NodeRead) -> Column SqlBool
 281          cond12 (nodeNgram, doc) =  _node_id doc
 282                                 .== _cnng_context_id nodeNgram
 283
 284          cond23 :: (NgramsRead, (ContextNodeNgramsRead, NodeReadNull)) -> Column SqlBool
 285          cond23 (ngrams', (nodeNgram, _)) =  ngrams'^.ngrams_id
 286                                         .== _cnng_ngrams_id nodeNgram
 287
 288          cond34 :: (ContextNodeNgramsRead, (NgramsRead, (ContextNodeNgramsReadNull, NodeReadNull))) -> Column SqlBool
 289          cond34 (nodeNgram2, (ngrams', (_,_)))= ngrams'^.ngrams_id .== _cnng_ngrams_id       nodeNgram2
 290
 291          cond45 :: (NodeRead, (ContextNodeNgramsRead, (NgramsReadNull, (ContextNodeNgramsReadNull, NodeReadNull)))) -> Column SqlBool
 292          cond45 (contact', (nodeNgram2', (_, (_,_)))) = _node_id  contact'  .== _cnng_context_id         nodeNgram2'
 293
 294
 295 ------------------------------------------------------------------------
 296 -- TODO-SECURITY check
 297 runViewDocuments :: HasDBid NodeType
 298                  => CorpusId
 299                  -> IsTrash
 300                  -> Maybe Offset
 301                  -> Maybe Limit
 302                  -> Maybe OrderBy
 303                  -> Maybe Text
 304                  -> Maybe Text
 305                  -> Cmd err [FacetDoc]
 306 runViewDocuments cId t o l order query year = do
 307     printDebug "[runViewDocuments] sqlQuery" $ showSql sqlQuery
 308     runOpaQuery $ filterWith o l order sqlQuery
 309   where
 310     sqlQuery = viewDocuments cId t (toDBid NodeDocument) query year
 311
 312 runCountDocuments :: HasDBid NodeType => CorpusId -> IsTrash -> Maybe Text -> Maybe Text -> Cmd err Int
 313 runCountDocuments cId t mQuery mYear = do
 314   runCountOpaQuery sqlQuery
 315   where
 316     sqlQuery = viewDocuments cId t (toDBid NodeDocument) mQuery mYear
 317
 318
 319 viewDocuments :: CorpusId
 320               -> IsTrash
 321               -> NodeTypeId
 322               -> Maybe Text
 323               -> Maybe Text
 324               -> Select FacetDocRead
 325 viewDocuments cId t ntId mQuery mYear = viewDocumentsQuery cId t ntId mQuery mYear >>> proc (c, nc) -> do
 326   returnA  -< FacetDoc { facetDoc_id         = _cs_id        c
 327                        , facetDoc_created    = _cs_date      c
 328                        , facetDoc_title      = _cs_name      c
 329                        , facetDoc_hyperdata  = _cs_hyperdata c
 330                        , facetDoc_category   = toNullable $ nc^.nc_category
 331                        , facetDoc_ngramCount = toNullable $ nc^.nc_score
 332                        , facetDoc_score      = toNullable $ nc^.nc_score
 333                        }
 334
 335 viewDocumentsQuery :: CorpusId
 336                    -> IsTrash
 337                    -> NodeTypeId
 338                    -> Maybe Text
 339                    -> Maybe Text
 340                    -> Select (ContextSearchRead, NodeContextRead)
 341 viewDocumentsQuery cId t ntId mQuery mYear = proc () -> do
 342   c  <- queryContextSearchTable -< ()
 343   nc <- queryNodeContextTable   -< ()
 344   restrict -< c^.cs_id         .== nc^.nc_context_id
 345   restrict -< nc^.nc_node_id   .== (pgNodeId cId)
 346   restrict -< c^.cs_typename   .== (sqlInt4 ntId)
 347   restrict -< if t then nc^.nc_category .== (sqlInt4 0)
 348                    else nc^.nc_category .>= (sqlInt4 1)
 349
 350   let
 351     query         = (fromMaybe "" mQuery)
 352     year          = (fromMaybe "" mYear)
 353     iLikeQuery    = T.intercalate "" ["%", query, "%"]
 354     abstractLHS h = fromNullable (sqlStrictText "")
 355                   $ toNullable h .->> (sqlStrictText "abstract")
 356     yearLHS h     = fromNullable (sqlStrictText "")
 357                   $ toNullable h .->> (sqlStrictText "publication_year")
 358
 359   restrict -<
 360     if query == "" then sqlBool True
 361       else  ((c^.cs_name) `ilike` (sqlStrictText iLikeQuery))
 362         .|| ((abstractLHS (c^.cs_hyperdata)) `ilike` (sqlStrictText iLikeQuery))
 363   restrict -<
 364     if year == "" then sqlBool True
 365       else (yearLHS (c^.cs_hyperdata)) .== (sqlStrictText year)
 366
 367   returnA -< (c, nc)
 368
 369
 370 ------------------------------------------------------------------------
 371 filterWith :: (SqlOrd date, SqlOrd title, SqlOrd category, SqlOrd score, hyperdata ~ Column SqlJsonb) =>
 372         Maybe Gargantext.Core.Types.Offset
 373      -> Maybe Gargantext.Core.Types.Limit
 374      -> Maybe OrderBy
 375      -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
 376      -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
 377 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
 378
 379
 380 orderWith :: (SqlOrd b1, SqlOrd b2, SqlOrd b3, SqlOrd b4)
 381           => Maybe OrderBy
 382           -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) ngramCount (Column b4))
 383 orderWith (Just DateAsc)   = asc  facetDoc_created
 384 orderWith (Just DateDesc)  = desc facetDoc_created
 385
 386 orderWith (Just TitleAsc)  = asc  facetDoc_title
 387 orderWith (Just TitleDesc) = desc facetDoc_title
 388
 389 orderWith (Just ScoreAsc)  = asc  facetDoc_score
 390 orderWith (Just ScoreDesc) = descNullsLast facetDoc_score
 391
 392 orderWith (Just SourceAsc)  = asc  facetDoc_source
 393 orderWith (Just SourceDesc) = desc facetDoc_source
 394
 395 orderWith _                = asc facetDoc_created
 396
 397 facetDoc_source :: SqlIsJson a
 398                 => Facet id created title (Column a) favorite ngramCount score
 399                 -> Column (Nullable SqlText)
 400 facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> sqlString "source"