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 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                -> Query 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 .== (pgBool t)
 270   -}
 271
 272   restrict -< _node_id   contact'  .== (toNullable $ pgNodeId cId)
 273   restrict -< _node_typename doc   .== (sqlInt4 $ toDBid nt)
 274
 275   returnA  -< FacetDoc (_node_id        doc)
 276                        (_node_date      doc)
 277                        (_node_name      doc)
 278                        (_node_hyperdata doc)
 279                        (toNullable $ sqlInt4 1)
 280                        (toNullable $ pgDouble 1)
 281                        (toNullable $ pgDouble 1)
 282
 283 queryAuthorsDoc :: Query (NodeRead, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull))))
 284 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNodeNgramsTable queryNgramsTable queryNodeNodeNgramsTable queryNodeTable cond12 cond23 cond34 cond45
 285     where
 286          cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
 287          cond12 (nodeNgram, doc) =  _node_id                  doc
 288                                 .== _nnng_node1_id nodeNgram
 289
 290          cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
 291          cond23 (ngrams', (nodeNgram, _)) =  ngrams'^.ngrams_id
 292                                         .== _nnng_ngrams_id nodeNgram
 293
 294          cond34 :: (NodeNodeNgramsRead, (NgramsRead, (NodeNodeNgramsReadNull, NodeReadNull))) -> Column PGBool
 295          cond34 (nodeNgram2, (ngrams', (_,_)))= ngrams'^.ngrams_id .== _nnng_ngrams_id       nodeNgram2
 296
 297          cond45 :: (NodeRead, (NodeNodeNgramsRead, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))) -> Column PGBool
 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               -> Query FacetDocRead
 349 viewDocuments cId t ntId mQuery = proc () -> do
 350   --n  <- queryNodeTable     -< ()
 351   n  <- queryNodeSearchTable -< ()
 352   nn <- queryNodeNodeTable -< ()
 353   restrict -< n^.ns_id       .== nn^.nn_node2_id
 354   restrict -< nn^.nn_node1_id  .== (pgNodeId cId)
 355   restrict -< n^.ns_typename .== (sqlInt4 ntId)
 356   restrict -< if t then nn^.nn_category .== (sqlInt4 0)
 357                    else nn^.nn_category .>= (sqlInt4 1)
 358
 359   let query = (fromMaybe "" mQuery)
 360       -- iLikeQuery = T.intercalate "" ["%", query, "%"]
 361   -- restrict -< (n^.node_name) `ilike` (sqlStrictText iLikeQuery)
 362   restrict -< if query == ""
 363     then pgBool True
 364     --else (n^.ns_search) @@ (pgTSQuery (T.unpack query))
 365     else (n^.ns_search) @@ (plaintoTSQuery $ T.unpack query)
 366
 367   returnA  -< FacetDoc (_ns_id        n)
 368                        (_ns_date      n)
 369                        (_ns_name      n)
 370                        (_ns_hyperdata n)
 371                        (toNullable $ nn^.nn_category)
 372                        (toNullable $ nn^.nn_score)
 373                        (toNullable $ nn^.nn_score)
 374
 375 ------------------------------------------------------------------------
 376 filterWith :: (SqlOrd date, SqlOrd title, SqlOrd category, SqlOrd score, hyperdata ~ Column SqlJsonb) =>
 377         Maybe Gargantext.Core.Types.Offset
 378      -> Maybe Gargantext.Core.Types.Limit
 379      -> Maybe OrderBy
 380      -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
 381      -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
 382 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
 383
 384
 385 orderWith :: (SqlOrd b1, SqlOrd b2, SqlOrd b3, SqlOrd b4)
 386           => Maybe OrderBy
 387           -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) ngramCount (Column b4))
 388 orderWith (Just DateAsc)   = asc  facetDoc_created
 389 orderWith (Just DateDesc)  = desc facetDoc_created
 390
 391 orderWith (Just TitleAsc)  = asc  facetDoc_title
 392 orderWith (Just TitleDesc) = desc facetDoc_title
 393
 394 orderWith (Just ScoreAsc)  = asc  facetDoc_score
 395 orderWith (Just ScoreDesc) = descNullsLast facetDoc_score
 396
 397 orderWith (Just SourceAsc)  = asc  facetDoc_source
 398 orderWith (Just SourceDesc) = desc facetDoc_source
 399
 400 orderWith _                = asc facetDoc_created
 401
 402 facetDoc_source :: SqlIsJson a
 403                 => Facet id created title (Column a) favorite ngramCount score
 404                 -> Column (Nullable PGText)
 405 facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> pgString "source"