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              | TagAsc     | TagDesc
 221              deriving (Generic, Enum, Bounded, Read, Show)
 222
 223 instance FromHttpApiData OrderBy
 224   where
 225     parseUrlPiece "DateAsc"    = pure DateAsc
 226     parseUrlPiece "DateDesc"   = pure DateDesc
 227     parseUrlPiece "TitleAsc"   = pure TitleAsc
 228     parseUrlPiece "TitleDesc"  = pure TitleDesc
 229     parseUrlPiece "ScoreAsc"   = pure ScoreAsc
 230     parseUrlPiece "ScoreDesc"  = pure ScoreDesc
 231     parseUrlPiece "SourceAsc"  = pure SourceAsc
 232     parseUrlPiece "SourceDesc" = pure SourceDesc
 233     parseUrlPiece "TagAsc"     = pure TagAsc
 234     parseUrlPiece "TagDesc"    = pure TagDesc
 235     parseUrlPiece _            = Left "Unexpected value of OrderBy"
 236 instance ToHttpApiData OrderBy where
 237   toUrlPiece = T.pack . show
 238
 239 instance ToParamSchema OrderBy
 240 instance FromJSON  OrderBy
 241 instance ToJSON    OrderBy
 242 instance ToSchema  OrderBy
 243 instance Arbitrary OrderBy
 244   where
 245     arbitrary = elements [minBound..maxBound]
 246
 247
 248 -- TODO-SECURITY check
 249 runViewAuthorsDoc :: HasDBid NodeType
 250                   => ContactId
 251                   -> IsTrash
 252                   -> Maybe Offset
 253                   -> Maybe Limit
 254                   -> Maybe OrderBy
 255                   -> Cmd err [FacetDoc]
 256 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
 257   where
 258     ntId = NodeDocument
 259
 260 -- TODO add delete ?
 261 viewAuthorsDoc :: HasDBid NodeType
 262                => ContactId
 263                -> IsTrash
 264                -> NodeType
 265                -> Select FacetDocRead
 266 viewAuthorsDoc cId _ nt = proc () -> do
 267   (doc,(_,(_,(_,contact')))) <- queryAuthorsDoc      -< ()
 268
 269   restrict -< _node_id   contact'  .== (toNullable $ pgNodeId cId)
 270   restrict -< _node_typename doc   .== (sqlInt4 $ toDBid nt)
 271
 272   returnA  -< FacetDoc { facetDoc_id         = _node_id        doc
 273                        , facetDoc_created    = _node_date      doc
 274                        , facetDoc_title      = _node_name      doc
 275                        , facetDoc_hyperdata  = _node_hyperdata doc
 276                        , facetDoc_category   = toNullable $ sqlInt4 1
 277                        , facetDoc_ngramCount = toNullable $ sqlDouble 1
 278                        , facetDoc_score      = toNullable $ sqlDouble 1 }
 279
 280 queryAuthorsDoc :: Select (NodeRead, (ContextNodeNgramsReadNull, (NgramsReadNull, (ContextNodeNgramsReadNull, NodeReadNull))))
 281 queryAuthorsDoc = leftJoin5 queryNodeTable queryContextNodeNgramsTable queryNgramsTable queryContextNodeNgramsTable queryNodeTable cond12 cond23 cond34 cond45
 282     where
 283          cond12 :: (ContextNodeNgramsRead, NodeRead) -> Column SqlBool
 284          cond12 (nodeNgram, doc) =  _node_id doc
 285                                 .== _cnng_context_id nodeNgram
 286
 287          cond23 :: (NgramsRead, (ContextNodeNgramsRead, NodeReadNull)) -> Column SqlBool
 288          cond23 (ngrams', (nodeNgram, _)) =  ngrams'^.ngrams_id
 289                                         .== _cnng_ngrams_id nodeNgram
 290
 291          cond34 :: (ContextNodeNgramsRead, (NgramsRead, (ContextNodeNgramsReadNull, NodeReadNull))) -> Column SqlBool
 292          cond34 (nodeNgram2, (ngrams', (_,_)))= ngrams'^.ngrams_id .== _cnng_ngrams_id       nodeNgram2
 293
 294          cond45 :: (NodeRead, (ContextNodeNgramsRead, (NgramsReadNull, (ContextNodeNgramsReadNull, NodeReadNull)))) -> Column SqlBool
 295          cond45 (contact', (nodeNgram2', (_, (_,_)))) = _node_id  contact'  .== _cnng_context_id         nodeNgram2'
 296
 297
 298 ------------------------------------------------------------------------
 299 -- TODO-SECURITY check
 300 runViewDocuments :: HasDBid NodeType
 301                  => CorpusId
 302                  -> IsTrash
 303                  -> Maybe Offset
 304                  -> Maybe Limit
 305                  -> Maybe OrderBy
 306                  -> Maybe Text
 307                  -> Maybe Text
 308                  -> Cmd err [FacetDoc]
 309 runViewDocuments cId t o l order query year = do
 310     printDebug "[runViewDocuments] sqlQuery" $ showSql sqlQuery
 311     runOpaQuery $ filterWith o l order sqlQuery
 312   where
 313     sqlQuery = viewDocuments cId t (toDBid NodeDocument) query year
 314
 315 runCountDocuments :: HasDBid NodeType => CorpusId -> IsTrash -> Maybe Text -> Maybe Text -> Cmd err Int
 316 runCountDocuments cId t mQuery mYear = do
 317   runCountOpaQuery sqlQuery
 318   where
 319     sqlQuery = viewDocuments cId t (toDBid NodeDocument) mQuery mYear
 320
 321
 322 viewDocuments :: CorpusId
 323               -> IsTrash
 324               -> NodeTypeId
 325               -> Maybe Text
 326               -> Maybe Text
 327               -> Select FacetDocRead
 328 viewDocuments cId t ntId mQuery mYear = viewDocumentsQuery cId t ntId mQuery mYear >>> proc (c, nc) -> do
 329   returnA  -< FacetDoc { facetDoc_id         = _cs_id        c
 330                        , facetDoc_created    = _cs_date      c
 331                        , facetDoc_title      = _cs_name      c
 332                        , facetDoc_hyperdata  = _cs_hyperdata c
 333                        , facetDoc_category   = toNullable $ nc^.nc_category
 334                        , facetDoc_ngramCount = toNullable $ nc^.nc_score
 335                        , facetDoc_score      = toNullable $ nc^.nc_score
 336                        }
 337
 338 viewDocumentsQuery :: CorpusId
 339                    -> IsTrash
 340                    -> NodeTypeId
 341                    -> Maybe Text
 342                    -> Maybe Text
 343                    -> Select (ContextSearchRead, NodeContextRead)
 344 viewDocumentsQuery cId t ntId mQuery mYear = proc () -> do
 345   c  <- queryContextSearchTable -< ()
 346   nc <- queryNodeContextTable   -< ()
 347   restrict -< c^.cs_id         .== nc^.nc_context_id
 348   restrict -< nc^.nc_node_id   .== (pgNodeId cId)
 349   restrict -< c^.cs_typename   .== (sqlInt4 ntId)
 350   restrict -< if t then nc^.nc_category .== (sqlInt4 0)
 351                    else nc^.nc_category .>= (sqlInt4 1)
 352
 353   let
 354     query         = (fromMaybe "" mQuery)
 355     year          = (fromMaybe "" mYear)
 356     iLikeQuery    = T.intercalate "" ["%", query, "%"]
 357     abstractLHS h = fromNullable (sqlStrictText "")
 358                   $ toNullable h .->> (sqlStrictText "abstract")
 359     yearLHS h     = fromNullable (sqlStrictText "")
 360                   $ toNullable h .->> (sqlStrictText "publication_year")
 361
 362   restrict -<
 363     if query == "" then sqlBool True
 364       else  ((c^.cs_name) `ilike` (sqlStrictText iLikeQuery))
 365         .|| ((abstractLHS (c^.cs_hyperdata)) `ilike` (sqlStrictText iLikeQuery))
 366   restrict -<
 367     if year == "" then sqlBool True
 368       else (yearLHS (c^.cs_hyperdata)) .== (sqlStrictText year)
 369
 370   returnA -< (c, nc)
 371
 372
 373 ------------------------------------------------------------------------
 374 filterWith :: (SqlOrd date, SqlOrd title, SqlOrd category, SqlOrd score, hyperdata ~ Column SqlJsonb) =>
 375         Maybe Gargantext.Core.Types.Offset
 376      -> Maybe Gargantext.Core.Types.Limit
 377      -> Maybe OrderBy
 378      -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
 379      -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
 380 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
 381
 382
 383 orderWith :: (SqlOrd b1, SqlOrd b2, SqlOrd b3, SqlOrd b4)
 384           => Maybe OrderBy
 385           -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) ngramCount (Column b4))
 386 orderWith (Just DateAsc)   = asc  facetDoc_created
 387 orderWith (Just DateDesc)  = desc facetDoc_created
 388
 389 orderWith (Just TitleAsc)  = asc  facetDoc_title
 390 orderWith (Just TitleDesc) = desc facetDoc_title
 391
 392 orderWith (Just ScoreAsc)  = asc  facetDoc_score
 393 orderWith (Just ScoreDesc) = descNullsLast facetDoc_score
 394
 395 orderWith (Just SourceAsc)  = asc  facetDoc_source
 396 orderWith (Just SourceDesc) = desc facetDoc_source
 397
 398 orderWith (Just TagAsc)     = asc  facetDoc_category
 399 orderWith (Just TagDesc)    = desc facetDoc_category
 400
 401 orderWith _                = asc facetDoc_created
 402
 403 facetDoc_source :: SqlIsJson a
 404                 => Facet id created title (Column a) favorite ngramCount score
 405                 -> Column (Nullable SqlText)
 406 facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> sqlString "source"