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                  -> Cmd err [FacetDoc]
 305 runViewDocuments cId t o l order query = do
 306     printDebug "[runViewDocuments] sqlQuery" $ showSql sqlQuery
 307     runOpaQuery $ filterWith o l order sqlQuery
 308   where
 309     sqlQuery = viewDocuments cId t (toDBid NodeDocument) query
 310
 311 runCountDocuments :: HasDBid NodeType => CorpusId -> IsTrash -> Maybe Text -> Cmd err Int
 312 runCountDocuments cId t mQuery = do
 313   runCountOpaQuery sqlQuery
 314   where
 315     sqlQuery = viewDocuments cId t (toDBid NodeDocument) mQuery
 316
 317
 318 viewDocuments :: CorpusId
 319               -> IsTrash
 320               -> NodeTypeId
 321               -> Maybe Text
 322               -> Select FacetDocRead
 323 viewDocuments cId t ntId mQuery = viewDocumentsQuery cId t ntId mQuery >>> proc (c, nc) -> do
 324   returnA  -< FacetDoc { facetDoc_id         = _cs_id        c
 325                        , facetDoc_created    = _cs_date      c
 326                        , facetDoc_title      = _cs_name      c
 327                        , facetDoc_hyperdata  = _cs_hyperdata c
 328                        , facetDoc_category   = toNullable $ nc^.nc_category
 329                        , facetDoc_ngramCount = toNullable $ nc^.nc_score
 330                        , facetDoc_score      = toNullable $ nc^.nc_score
 331                        }
 332
 333 viewDocumentsQuery :: CorpusId
 334                    -> IsTrash
 335                    -> NodeTypeId
 336                    -> Maybe Text
 337                    -> Select (ContextSearchRead, NodeContextRead)
 338 viewDocumentsQuery cId t ntId mQuery = proc () -> do
 339   c  <- queryContextSearchTable -< ()
 340   nc <- queryNodeContextTable   -< ()
 341   restrict -< c^.cs_id         .== nc^.nc_context_id
 342   restrict -< nc^.nc_node_id   .== (pgNodeId cId)
 343   restrict -< c^.cs_typename   .== (sqlInt4 ntId)
 344   restrict -< if t then nc^.nc_category .== (sqlInt4 0)
 345                    else nc^.nc_category .>= (sqlInt4 1)
 346
 347   let
 348     query         = (fromMaybe "" mQuery)
 349     iLikeQuery    = T.intercalate "" ["%", query, "%"]
 350     abstractLHS h = fromNullable (sqlStrictText "")
 351                   $ toNullable h .->> (sqlStrictText "abstract")
 352
 353   restrict -<
 354     if query == "" then sqlBool True
 355       else  ((c^.cs_name) `ilike` (sqlStrictText iLikeQuery))
 356         .|| ((abstractLHS (c^.cs_hyperdata)) `ilike` (sqlStrictText iLikeQuery))
 357
 358   returnA -< (c, nc)
 359
 360
 361 ------------------------------------------------------------------------
 362 filterWith :: (SqlOrd date, SqlOrd title, SqlOrd category, SqlOrd score, hyperdata ~ Column SqlJsonb) =>
 363         Maybe Gargantext.Core.Types.Offset
 364      -> Maybe Gargantext.Core.Types.Limit
 365      -> Maybe OrderBy
 366      -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
 367      -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
 368 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
 369
 370
 371 orderWith :: (SqlOrd b1, SqlOrd b2, SqlOrd b3, SqlOrd b4)
 372           => Maybe OrderBy
 373           -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) ngramCount (Column b4))
 374 orderWith (Just DateAsc)   = asc  facetDoc_created
 375 orderWith (Just DateDesc)  = desc facetDoc_created
 376
 377 orderWith (Just TitleAsc)  = asc  facetDoc_title
 378 orderWith (Just TitleDesc) = desc facetDoc_title
 379
 380 orderWith (Just ScoreAsc)  = asc  facetDoc_score
 381 orderWith (Just ScoreDesc) = descNullsLast facetDoc_score
 382
 383 orderWith (Just SourceAsc)  = asc  facetDoc_source
 384 orderWith (Just SourceDesc) = desc facetDoc_source
 385
 386 orderWith _                = asc facetDoc_created
 387
 388 facetDoc_source :: SqlIsJson a
 389                 => Facet id created title (Column a) favorite ngramCount score
 390                 -> Column (Nullable SqlText)
 391 facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> sqlString "source"