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.Node (queryNodeSearchTable)
  70 import Gargantext.Database.Query.Table.NodeNode
  71 import Gargantext.Database.Query.Table.NodeNodeNgrams
  72 import Gargantext.Database.Prelude
  73 import Gargantext.Database.Schema.Node
  74 import Gargantext.Prelude (printDebug)
  75
  76 ------------------------------------------------------------------------
  77 -- | DocFacet
  78
  79 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
  80 --    deriving (Show, Generic)
  81 --instance FromJSON Facet
  82 --instance ToJSON   Facet
  83
  84 type Category = Int
  85 type Score    = Double
  86 type Title    = Text
  87
  88 -- TODO remove Title
  89 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Category) (Maybe Double) (Maybe Score)
  90 -- type FacetSources = FacetDoc
  91 -- type FacetAuthors = FacetDoc
  92 -- type FacetTerms   = FacetDoc
  93
  94
  95 data Facet id created title hyperdata category ngramCount score =
  96      FacetDoc { facetDoc_id         :: id
  97               , facetDoc_created    :: created
  98               , facetDoc_title      :: title
  99               , facetDoc_hyperdata  :: hyperdata
 100               , facetDoc_category   :: category
 101               , facetDoc_ngramCount :: ngramCount
 102               , facetDoc_score      :: score
 103               } deriving (Show, Generic)
 104 {- | TODO after demo
 105 data Facet id date hyperdata score =
 106      FacetDoc { facetDoc_id        :: id
 107               , facetDoc_date      :: date
 108               , facetDoc_hyperdata :: hyperdata
 109               , facetDoc_score     :: score
 110               } deriving (Show, Generic)
 111 -}
 112
 113 data Pair i l = Pair {
 114     _p_id    :: i
 115   , _p_label :: l
 116   } deriving (Show, Generic)
 117 $(deriveJSON (unPrefix "_p_") ''Pair)
 118 $(makeAdaptorAndInstance "pPair" ''Pair)
 119
 120 instance (Typeable i, Typeable l, ToSchema i, ToSchema l) => ToSchema (Pair i l) where
 121   declareNamedSchema = wellNamedSchema "_p_"
 122 instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
 123   arbitrary = Pair <$> arbitrary <*> arbitrary
 124
 125 data FacetPaired id date hyperdata score =
 126   FacetPaired { _fp_id        :: id
 127               , _fp_date      :: date
 128               , _fp_hyperdata :: hyperdata
 129               , _fp_score     :: score }
 130   deriving (Show, Generic)
 131 $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
 132 $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
 133
 134
 135
 136 instance ( ToSchema id
 137          , ToSchema date
 138          , ToSchema hyperdata
 139          , ToSchema score
 140          , Typeable id
 141          , Typeable date
 142          , Typeable hyperdata
 143          , Typeable score
 144          ) => ToSchema (FacetPaired id date hyperdata score) where
 145   declareNamedSchema = wellNamedSchema "_fp_"
 146
 147 instance ( Arbitrary id
 148          , Arbitrary date
 149          , Arbitrary hyperdata
 150          , Arbitrary score
 151          ) => Arbitrary (FacetPaired id date hyperdata score) where
 152   arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 153
 154 type FacetPairedRead = FacetPaired (Column SqlInt4       )
 155                                    (Column SqlTimestamptz)
 156                                    (Column SqlJsonb      )
 157                                    (Column SqlInt4       )
 158
 159 type FacetPairedReadNull = FacetPaired (Column (Nullable SqlInt4)       )
 160                                        (Column (Nullable SqlTimestamptz))
 161                                        (Column (Nullable SqlJsonb)      )
 162                                        (Column (Nullable SqlInt4)       )
 163
 164 type FacetPairedReadNullAgg = FacetPaired (Aggregator (Column (Nullable SqlInt4)       )
 165                                                       (Column (Nullable SqlInt4)       )
 166                                           )
 167                                           (Aggregator (Column (Nullable SqlTimestamptz))
 168                                                       (Column (Nullable SqlTimestamptz))
 169
 170                                           )
 171                                           (Aggregator (Column (Nullable SqlJsonb)      )
 172                                                       (Column (Nullable SqlJsonb)      )
 173                                           )
 174                                           (Aggregator (Column (Nullable SqlInt4)       )
 175                                                       (Column (Nullable SqlInt4)       )
 176                                           )
 177
 178
 179
 180
 181 -- | JSON instance
 182 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
 183
 184 -- | Documentation instance
 185 instance ToSchema FacetDoc where
 186   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "facetDoc_")
 187
 188 -- | Mock and Quickcheck instances
 189 instance Arbitrary FacetDoc where
 190     arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp (Just cat) (Just ngramCount) (Just score)
 191                          | id'  <- [1..10]
 192                          , year <- [1990..2000]
 193                          , t    <- ["title", "another title"]
 194                          , hp   <- arbitraryHyperdataDocuments
 195                          , cat  <- [0..2]
 196                          , ngramCount <- [3..100]
 197                          , score <- [3..100]
 198                          ]
 199
 200 -- Facets / Views for the Front End
 201 -- | Database instances
 202 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
 203 -- $(makeLensesWith abbreviatedFields   ''Facet)
 204
 205 type FacetDocRead = Facet (Column SqlInt4       )
 206                           (Column SqlTimestamptz)
 207                           (Column SqlText       )
 208                           (Column SqlJsonb      )
 209                           (Column (Nullable SqlInt4)) -- Category
 210                           (Column (Nullable SqlFloat8)) -- Ngrams Count
 211                           (Column (Nullable SqlFloat8)) -- Score
 212
 213 -----------------------------------------------------------------------
 214 -----------------------------------------------------------------------
 215 data OrderBy =  DateAsc   | DateDesc
 216              | TitleAsc   | TitleDesc
 217              | ScoreDesc  | ScoreAsc
 218              | SourceAsc  | SourceDesc
 219              deriving (Generic, Enum, Bounded, Read, Show)
 220
 221 instance FromHttpApiData OrderBy
 222   where
 223     parseUrlPiece "DateAsc"    = pure DateAsc
 224     parseUrlPiece "DateDesc"   = pure DateDesc
 225     parseUrlPiece "TitleAsc"   = pure TitleAsc
 226     parseUrlPiece "TitleDesc"  = pure TitleDesc
 227     parseUrlPiece "ScoreAsc"   = pure ScoreAsc
 228     parseUrlPiece "ScoreDesc"  = pure ScoreDesc
 229     parseUrlPiece "SourceAsc"  = pure SourceAsc
 230     parseUrlPiece "SourceDesc" = pure SourceDesc
 231     parseUrlPiece _            = Left "Unexpected value of OrderBy"
 232 instance ToHttpApiData OrderBy where
 233   toUrlPiece = T.pack . show
 234
 235 instance ToParamSchema OrderBy
 236 instance FromJSON  OrderBy
 237 instance ToJSON    OrderBy
 238 instance ToSchema  OrderBy
 239 instance Arbitrary OrderBy
 240   where
 241     arbitrary = elements [minBound..maxBound]
 242
 243
 244 -- TODO-SECURITY check
 245
 246 --{-
 247 runViewAuthorsDoc :: HasDBid NodeType
 248                   => ContactId
 249                   -> IsTrash
 250                   -> Maybe Offset
 251                   -> Maybe Limit
 252                   -> Maybe OrderBy
 253                   -> Cmd err [FacetDoc]
 254 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
 255   where
 256     ntId = NodeDocument
 257
 258 -- TODO add delete ?
 259 viewAuthorsDoc :: HasDBid NodeType
 260                => ContactId
 261                -> IsTrash
 262                -> NodeType
 263                -> Select FacetDocRead
 264 viewAuthorsDoc cId _ nt = proc () -> do
 265   (doc,(_,(_,(_,contact')))) <- queryAuthorsDoc      -< ()
 266
 267   {-nn         <- queryNodeNodeTable -< ()
 268   restrict -< nn_node1_id nn .== _node_id doc
 269   -- restrict -< nn_delete   nn .== (sqlBool t)
 270   -}
 271
 272   restrict -< _node_id   contact'  .== (toNullable $ pgNodeId cId)
 273   restrict -< _node_typename doc   .== (sqlInt4 $ toDBid nt)
 274
 275   returnA  -< FacetDoc { facetDoc_id         = _node_id        doc
 276                        , facetDoc_created    = _node_date      doc
 277                        , facetDoc_title      = _node_name      doc
 278                        , facetDoc_hyperdata  = _node_hyperdata doc
 279                        , facetDoc_category   = toNullable $ sqlInt4 1
 280                        , facetDoc_ngramCount = toNullable $ sqlDouble 1
 281                        , facetDoc_score      = toNullable $ sqlDouble 1 }
 282
 283 queryAuthorsDoc :: Select (NodeRead, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull))))
 284 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNodeNgramsTable queryNgramsTable queryNodeNodeNgramsTable queryNodeTable cond12 cond23 cond34 cond45
 285     where
 286          cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column SqlBool
 287          cond12 (nodeNgram, doc) =  _node_id                  doc
 288                                 .== _nnng_node1_id nodeNgram
 289
 290          cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column SqlBool
 291          cond23 (ngrams', (nodeNgram, _)) =  ngrams'^.ngrams_id
 292                                         .== _nnng_ngrams_id nodeNgram
 293
 294          cond34 :: (NodeNodeNgramsRead, (NgramsRead, (NodeNodeNgramsReadNull, NodeReadNull))) -> Column SqlBool
 295          cond34 (nodeNgram2, (ngrams', (_,_)))= ngrams'^.ngrams_id .== _nnng_ngrams_id       nodeNgram2
 296
 297          cond45 :: (NodeRead, (NodeNodeNgramsRead, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))) -> Column SqlBool
 298          cond45 (contact', (nodeNgram2', (_, (_,_)))) = _node_id  contact'  .== _nnng_node1_id         nodeNgram2'
 299
 300 --}
 301 ------------------------------------------------------------------------
 302
 303 -- TODO-SECURITY check
 304 runViewDocuments :: HasDBid NodeType
 305                  => CorpusId
 306                  -> IsTrash
 307                  -> Maybe Offset
 308                  -> Maybe Limit
 309                  -> Maybe OrderBy
 310                  -> Maybe Text
 311                  -> Cmd err [FacetDoc]
 312 runViewDocuments cId t o l order query = do
 313 --  docs <- runPGSQuery viewDocuments'
 314 --    ( cId
 315 --    , ntId
 316 --    , (if t then 0 else 1) :: Int
 317 --    , fromMaybe "" query
 318 --    , fromMaybe "" query)
 319 --  pure $ (\(id, date, name', hyperdata, category, score) -> FacetDoc id date name' hyperdata category score score) <$> docs
 320     printDebug "[runViewDocuments] sqlQuery" $ showSql sqlQuery
 321     runOpaQuery $ filterWith o l order sqlQuery
 322   where
 323     ntId = toDBid NodeDocument
 324     sqlQuery = viewDocuments cId t ntId query
 325 --    viewDocuments' :: DPS.Query
 326 --    viewDocuments' = [sql|
 327 --      SELECT n.id, n.date, n.name, n.hyperdata, nn.category, nn.score
 328 --        FROM nodes AS n
 329 --        JOIN nodes_nodes AS nn
 330 --        ON n.id = nn.node2_id
 331 --        WHERE nn.node1_id = ?  -- corpusId
 332 --          AND n.typename = ?   -- NodeTypeId
 333 --          AND nn.category = ?  -- isTrash or not
 334 --          AND (n.search @@ to_tsquery(?) OR ? = '')  -- query with an OR hack for empty to_tsquery('') results
 335 --      |]
 336
 337 runCountDocuments :: HasDBid NodeType => CorpusId -> IsTrash -> Maybe Text -> Cmd err Int
 338 runCountDocuments cId t mQuery = do
 339   runCountOpaQuery sqlQuery
 340   where
 341     sqlQuery = viewDocuments cId t (toDBid NodeDocument) mQuery
 342
 343
 344 viewDocuments :: CorpusId
 345               -> IsTrash
 346               -> NodeTypeId
 347               -> Maybe Text
 348               -> Select FacetDocRead
 349 viewDocuments cId t ntId mQuery = viewDocumentsQuery cId t ntId mQuery >>> proc (n, nn) -> do
 350   returnA  -< FacetDoc { facetDoc_id         = _ns_id        n
 351                        , facetDoc_created    = _ns_date      n
 352                        , facetDoc_title      = _ns_name      n
 353                        , facetDoc_hyperdata  = _ns_hyperdata n
 354                        , facetDoc_category   = toNullable $ nn^.nn_category
 355                        , facetDoc_ngramCount = toNullable $ nn^.nn_score
 356                        , facetDoc_score      = toNullable $ nn^.nn_score }
 357
 358 viewDocuments' :: CorpusId
 359                -> IsTrash
 360                -> NodeTypeId
 361                -> Maybe Text
 362                -> Select NodeRead
 363 viewDocuments' cId t ntId mQuery = viewDocumentsQuery cId t ntId mQuery >>> proc (n, _nn) -> do
 364   returnA  -< Node { _node_id        = _ns_id        n
 365                    , _node_hash_id   = ""
 366                    , _node_typename  = _ns_typename  n
 367                    , _node_user_id   = _ns_user_id   n
 368                    , _node_parent_id = -1
 369                    , _node_name      = _ns_name      n
 370                    , _node_date      = _ns_date      n
 371                    , _node_hyperdata = _ns_hyperdata n }
 372
 373 viewDocumentsQuery :: CorpusId
 374                    -> IsTrash
 375                    -> NodeTypeId
 376                    -> Maybe Text
 377                    -> Select (NodeSearchRead, NodeNodeRead)
 378 viewDocumentsQuery cId t ntId mQuery = proc () -> do
 379   n  <- queryNodeSearchTable -< ()
 380   nn <- queryNodeNodeTable -< ()
 381   restrict -< n^.ns_id       .== nn^.nn_node2_id
 382   restrict -< nn^.nn_node1_id  .== (pgNodeId cId)
 383   restrict -< n^.ns_typename .== (sqlInt4 ntId)
 384   restrict -< if t then nn^.nn_category .== (sqlInt4 0)
 385                    else nn^.nn_category .>= (sqlInt4 1)
 386
 387   let query = (fromMaybe "" mQuery)
 388       -- iLikeQuery = T.intercalate "" ["%", query, "%"]
 389   -- restrict -< (n^.node_name) `ilike` (sqlStrictText iLikeQuery)
 390   restrict -< if query == ""
 391     then sqlBool True
 392     --else (n^.ns_search) @@ (pgTSQuery (T.unpack query))
 393     else (n^.ns_search) @@ (plaintoTSQuery $ T.unpack query)
 394
 395   returnA -< (n, nn)
 396
 397 ------------------------------------------------------------------------
 398 filterWith :: (SqlOrd date, SqlOrd title, SqlOrd category, SqlOrd score, hyperdata ~ Column SqlJsonb) =>
 399         Maybe Gargantext.Core.Types.Offset
 400      -> Maybe Gargantext.Core.Types.Limit
 401      -> Maybe OrderBy
 402      -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
 403      -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
 404 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
 405
 406
 407 orderWith :: (SqlOrd b1, SqlOrd b2, SqlOrd b3, SqlOrd b4)
 408           => Maybe OrderBy
 409           -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) ngramCount (Column b4))
 410 orderWith (Just DateAsc)   = asc  facetDoc_created
 411 orderWith (Just DateDesc)  = desc facetDoc_created
 412
 413 orderWith (Just TitleAsc)  = asc  facetDoc_title
 414 orderWith (Just TitleDesc) = desc facetDoc_title
 415
 416 orderWith (Just ScoreAsc)  = asc  facetDoc_score
 417 orderWith (Just ScoreDesc) = descNullsLast facetDoc_score
 418
 419 orderWith (Just SourceAsc)  = asc  facetDoc_source
 420 orderWith (Just SourceDesc) = desc facetDoc_source
 421
 422 orderWith _                = asc facetDoc_created
 423
 424 facetDoc_source :: SqlIsJson a
 425                 => Facet id created title (Column a) favorite ngramCount score
 426                 -> Column (Nullable SqlText)
 427 facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> sqlString "source"