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