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
  14 {-# LANGUAGE Arrows                    #-}
  15 {-# LANGUAGE FunctionalDependencies    #-}
  16 {-# LANGUAGE QuasiQuotes               #-}
  17 {-# LANGUAGE NoMonomorphismRestriction #-}
  18 {-# LANGUAGE TemplateHaskell           #-}
  19 {-# LANGUAGE TypeFamilies              #-}
  20 ------------------------------------------------------------------------
  21 module Gargantext.Database.Query.Facet
  22   ( runViewAuthorsDoc
  23   , runViewDocuments
  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 PGInt4       )
 155                                    (Column PGTimestamptz)
 156                                    (Column PGJsonb      )
 157                                    (Column PGInt4       )
 158
 159 type FacetPairedReadNull = FacetPaired (Column (Nullable PGInt4)       )
 160                                        (Column (Nullable PGTimestamptz))
 161                                        (Column (Nullable PGJsonb)      )
 162                                        (Column (Nullable PGInt4)       )
 163
 164 type FacetPairedReadNullAgg = FacetPaired (Aggregator (Column (Nullable PGInt4)       )
 165                                                       (Column (Nullable PGInt4)       )
 166                                           )
 167                                           (Aggregator (Column (Nullable PGTimestamptz))
 168                                                       (Column (Nullable PGTimestamptz))
 169
 170                                           )
 171                                           (Aggregator (Column (Nullable PGJsonb)      )
 172                                                       (Column (Nullable PGJsonb)      )
 173                                           )
 174                                           (Aggregator (Column (Nullable PGInt4)       )
 175                                                       (Column (Nullable PGInt4)       )
 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 PGInt4       )
 206                           (Column PGTimestamptz)
 207                           (Column PGText       )
 208                           (Column PGJsonb      )
 209                           (Column (Nullable PGInt4)) -- Category
 210                           (Column (Nullable PGFloat8)) -- Ngrams Count
 211                           (Column (Nullable PGFloat8)) -- 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
 233 instance ToParamSchema OrderBy
 234 instance FromJSON  OrderBy
 235 instance ToJSON    OrderBy
 236 instance ToSchema  OrderBy
 237 instance Arbitrary OrderBy
 238   where
 239     arbitrary = elements [minBound..maxBound]
 240
 241
 242 -- TODO-SECURITY check
 243
 244 --{-
 245 runViewAuthorsDoc :: HasDBid NodeType
 246                   => ContactId
 247                   -> IsTrash
 248                   -> Maybe Offset
 249                   -> Maybe Limit
 250                   -> Maybe OrderBy
 251                   -> Cmd err [FacetDoc]
 252 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
 253   where
 254     ntId = NodeDocument
 255
 256 -- TODO add delete ?
 257 viewAuthorsDoc :: HasDBid NodeType
 258                => ContactId
 259                -> IsTrash
 260                -> NodeType
 261                -> Query FacetDocRead
 262 viewAuthorsDoc cId _ nt = proc () -> do
 263   (doc,(_,(_,(_,contact')))) <- queryAuthorsDoc      -< ()
 264
 265   {-nn         <- queryNodeNodeTable -< ()
 266   restrict -< nn_node1_id nn .== _node_id doc
 267   -- restrict -< nn_delete   nn .== (pgBool t)
 268   -}
 269
 270   restrict -< _node_id   contact'  .== (toNullable $ pgNodeId cId)
 271   restrict -< _node_typename doc   .== (sqlInt4 $ toDBid nt)
 272
 273   returnA  -< FacetDoc (_node_id        doc)
 274                        (_node_date      doc)
 275                        (_node_name      doc)
 276                        (_node_hyperdata doc)
 277                        (toNullable $ sqlInt4 1)
 278                        (toNullable $ pgDouble 1)
 279                        (toNullable $ pgDouble 1)
 280
 281 queryAuthorsDoc :: Query (NodeRead, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull))))
 282 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNodeNgramsTable queryNgramsTable queryNodeNodeNgramsTable queryNodeTable cond12 cond23 cond34 cond45
 283     where
 284          cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
 285          cond12 (nodeNgram, doc) =  _node_id                  doc
 286                                 .== _nnng_node1_id nodeNgram
 287
 288          cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
 289          cond23 (ngrams', (nodeNgram, _)) =  ngrams'^.ngrams_id
 290                                         .== _nnng_ngrams_id nodeNgram
 291
 292          cond34 :: (NodeNodeNgramsRead, (NgramsRead, (NodeNodeNgramsReadNull, NodeReadNull))) -> Column PGBool
 293          cond34 (nodeNgram2, (ngrams', (_,_)))= ngrams'^.ngrams_id .== _nnng_ngrams_id       nodeNgram2
 294
 295          cond45 :: (NodeRead, (NodeNodeNgramsRead, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))) -> Column PGBool
 296          cond45 (contact', (nodeNgram2', (_, (_,_)))) = _node_id  contact'  .== _nnng_node1_id         nodeNgram2'
 297
 298 --}
 299 ------------------------------------------------------------------------
 300
 301 -- TODO-SECURITY check
 302 runViewDocuments :: HasDBid NodeType
 303                  => CorpusId
 304                  -> IsTrash
 305                  -> Maybe Offset
 306                  -> Maybe Limit
 307                  -> Maybe OrderBy
 308                  -> Maybe Text
 309                  -> Cmd err [FacetDoc]
 310 runViewDocuments cId t o l order query = do
 311 --  docs <- runPGSQuery viewDocuments'
 312 --    ( cId
 313 --    , ntId
 314 --    , (if t then 0 else 1) :: Int
 315 --    , fromMaybe "" query
 316 --    , fromMaybe "" query)
 317 --  pure $ (\(id, date, name', hyperdata, category, score) -> FacetDoc id date name' hyperdata category score score) <$> docs
 318     printDebug "[runViewDocuments] sqlQuery" $ showSql sqlQuery
 319     runOpaQuery $ filterWith o l order sqlQuery
 320   where
 321     ntId = toDBid NodeDocument
 322     sqlQuery = viewDocuments cId t ntId query
 323 --    viewDocuments' :: DPS.Query
 324 --    viewDocuments' = [sql|
 325 --      SELECT n.id, n.date, n.name, n.hyperdata, nn.category, nn.score
 326 --        FROM nodes AS n
 327 --        JOIN nodes_nodes AS nn
 328 --        ON n.id = nn.node2_id
 329 --        WHERE nn.node1_id = ?  -- corpusId
 330 --          AND n.typename = ?   -- NodeTypeId
 331 --          AND nn.category = ?  -- isTrash or not
 332 --          AND (n.search_title @@ to_tsquery(?) OR ? = '')  -- query with an OR hack for empty to_tsquery('') results
 333 --      |]
 334
 335 runCountDocuments :: HasDBid NodeType => CorpusId -> IsTrash -> Maybe Text -> Cmd err Int
 336 runCountDocuments cId t mQuery = do
 337   runCountOpaQuery sqlQuery
 338   where
 339     sqlQuery = viewDocuments cId t (toDBid NodeDocument) mQuery
 340
 341
 342 viewDocuments :: CorpusId
 343               -> IsTrash
 344               -> NodeTypeId
 345               -> Maybe Text
 346               -> Query FacetDocRead
 347 viewDocuments cId t ntId mQuery = proc () -> do
 348   --n  <- queryNodeTable     -< ()
 349   n  <- queryNodeSearchTable -< ()
 350   nn <- queryNodeNodeTable -< ()
 351   restrict -< n^.ns_id       .== nn^.nn_node2_id
 352   restrict -< nn^.nn_node1_id  .== (pgNodeId cId)
 353   restrict -< n^.ns_typename .== (sqlInt4 ntId)
 354   restrict -< if t then nn^.nn_category .== (sqlInt4 0)
 355                    else nn^.nn_category .>= (sqlInt4 1)
 356
 357   let query = (fromMaybe "" mQuery)
 358       -- iLikeQuery = T.intercalate "" ["%", query, "%"]
 359   -- restrict -< (n^.node_name) `ilike` (sqlStrictText iLikeQuery)
 360   restrict -< if query == ""
 361     then pgBool True
 362     --else (n^.ns_search_title) @@ (pgTSQuery (T.unpack query))
 363     else (n^.ns_search_title) @@ (toTSQuery $ T.unpack query)
 364
 365   returnA  -< FacetDoc (_ns_id        n)
 366                        (_ns_date      n)
 367                        (_ns_name      n)
 368                        (_ns_hyperdata n)
 369                        (toNullable $ nn^.nn_category)
 370                        (toNullable $ nn^.nn_score)
 371                        (toNullable $ nn^.nn_score)
 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 _                = asc facetDoc_created
 399
 400 facetDoc_source :: SqlIsJson a
 401                 => Facet id created title (Column a) favorite ngramCount score
 402                 -> Column (Nullable PGText)
 403 facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> pgString "source"