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 Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  48 import Data.Swagger
  49 import qualified Data.Text as T
  50 import Data.Time (UTCTime)
  51 import Data.Time.Segment (jour)
  52 import Opaleye
  53 import Protolude hiding (null, map, sum, not)
  54 import Servant.API
  55 import Test.QuickCheck (elements)
  56 import Test.QuickCheck.Arbitrary
  57 import qualified Opaleye.Internal.Unpackspec()
  58
  59 import Gargantext.Core
  60 import Gargantext.Core.Types
  61 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
  62 import Gargantext.Database.Admin.Types.Hyperdata
  63 import Gargantext.Database.Query.Filter
  64 import Gargantext.Database.Query.Join (leftJoin5)
  65 import Gargantext.Database.Query.Table.Ngrams
  66 import Gargantext.Database.Query.Table.NodeNode
  67 import Gargantext.Database.Query.Table.NodeNodeNgrams
  68 import Gargantext.Database.Prelude
  69 import Gargantext.Database.Schema.Node
  70
  71 ------------------------------------------------------------------------
  72 -- | DocFacet
  73
  74 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
  75 --    deriving (Show, Generic)
  76 --instance FromJSON Facet
  77 --instance ToJSON   Facet
  78
  79 type Category = Int
  80 type Score    = Double
  81 type Title    = Text
  82
  83 -- TODO remove Title
  84 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Category) (Maybe Double) (Maybe Score)
  85 -- type FacetSources = FacetDoc
  86 -- type FacetAuthors = FacetDoc
  87 -- type FacetTerms   = FacetDoc
  88
  89
  90 data Facet id created title hyperdata category ngramCount score =
  91      FacetDoc { facetDoc_id         :: id
  92               , facetDoc_created    :: created
  93               , facetDoc_title      :: title
  94               , facetDoc_hyperdata  :: hyperdata
  95               , facetDoc_category   :: category
  96               , facetDoc_ngramCount :: ngramCount
  97               , facetDoc_score      :: score
  98               } deriving (Show, Generic)
  99 {- | TODO after demo
 100 data Facet id date hyperdata score =
 101      FacetDoc { facetDoc_id        :: id
 102               , facetDoc_date      :: date
 103               , facetDoc_hyperdata :: hyperdata
 104               , facetDoc_score     :: score
 105               } deriving (Show, Generic)
 106 -}
 107
 108 data Pair i l = Pair {
 109     _p_id    :: i
 110   , _p_label :: l
 111   } deriving (Show, Generic)
 112 $(deriveJSON (unPrefix "_p_") ''Pair)
 113 $(makeAdaptorAndInstance "pPair" ''Pair)
 114
 115 instance (Typeable i, Typeable l, ToSchema i, ToSchema l) => ToSchema (Pair i l) where
 116   declareNamedSchema = wellNamedSchema "_p_"
 117 instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
 118   arbitrary = Pair <$> arbitrary <*> arbitrary
 119
 120 data FacetPaired id date hyperdata score =
 121   FacetPaired {_fp_id        :: id
 122               ,_fp_date      :: date
 123               ,_fp_hyperdata :: hyperdata
 124               ,_fp_score     :: score
 125   } deriving (Show, Generic)
 126 $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
 127 $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
 128
 129
 130
 131 instance ( ToSchema id
 132          , ToSchema date
 133          , ToSchema hyperdata
 134          , ToSchema score
 135          , Typeable id
 136          , Typeable date
 137          , Typeable hyperdata
 138          , Typeable score
 139          ) => ToSchema (FacetPaired id date hyperdata score) where
 140   declareNamedSchema = wellNamedSchema "_fp_"
 141
 142 instance ( Arbitrary id
 143          , Arbitrary date
 144          , Arbitrary hyperdata
 145          , Arbitrary score
 146          ) => Arbitrary (FacetPaired id date hyperdata score) where
 147   arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 148
 149 type FacetPairedRead = FacetPaired (Column PGInt4       )
 150                                    (Column PGTimestamptz)
 151                                    (Column PGJsonb      )
 152                                    (Column PGInt4       )
 153
 154 type FacetPairedReadNull = FacetPaired (Column (Nullable PGInt4)       )
 155                                        (Column (Nullable PGTimestamptz))
 156                                        (Column (Nullable PGJsonb)      )
 157                                        (Column (Nullable PGInt4)       )
 158
 159 type FacetPairedReadNullAgg = FacetPaired (Aggregator (Column (Nullable PGInt4)       )
 160                                                       (Column (Nullable PGInt4)       )
 161                                           )
 162                                           (Aggregator (Column (Nullable PGTimestamptz))
 163                                                       (Column (Nullable PGTimestamptz))
 164
 165                                           )
 166                                           (Aggregator (Column (Nullable PGJsonb)      )
 167                                                       (Column (Nullable PGJsonb)      )
 168                                           )
 169                                           (Aggregator (Column (Nullable PGInt4)       )
 170                                                       (Column (Nullable PGInt4)       )
 171                                           )
 172
 173
 174
 175
 176 -- | JSON instance
 177 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
 178
 179 -- | Documentation instance
 180 instance ToSchema FacetDoc where
 181   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "facetDoc_")
 182
 183 -- | Mock and Quickcheck instances
 184 instance Arbitrary FacetDoc where
 185     arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp (Just cat) (Just ngramCount) (Just score)
 186                          | id'  <- [1..10]
 187                          , year <- [1990..2000]
 188                          , t    <- ["title", "another title"]
 189                          , hp   <- arbitraryHyperdataDocuments
 190                          , cat  <- [0..2]
 191                          , ngramCount <- [3..100]
 192                          , score <- [3..100]
 193                          ]
 194
 195 -- Facets / Views for the Front End
 196 -- | Database instances
 197 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
 198 -- $(makeLensesWith abbreviatedFields   ''Facet)
 199
 200 type FacetDocRead = Facet (Column PGInt4       )
 201                           (Column PGTimestamptz)
 202                           (Column PGText       )
 203                           (Column PGJsonb      )
 204                           (Column (Nullable PGInt4)) -- Category
 205                           (Column (Nullable PGFloat8)) -- Ngrams Count
 206                           (Column (Nullable PGFloat8)) -- Score
 207
 208 -----------------------------------------------------------------------
 209 -----------------------------------------------------------------------
 210 data OrderBy =  DateAsc   | DateDesc
 211              | TitleAsc   | TitleDesc
 212              | ScoreDesc  | ScoreAsc
 213              | SourceAsc  | SourceDesc
 214              deriving (Generic, Enum, Bounded, Read, Show)
 215
 216 instance FromHttpApiData OrderBy
 217   where
 218     parseUrlPiece "DateAsc"    = pure DateAsc
 219     parseUrlPiece "DateDesc"   = pure DateDesc
 220     parseUrlPiece "TitleAsc"   = pure TitleAsc
 221     parseUrlPiece "TitleDesc"  = pure TitleDesc
 222     parseUrlPiece "ScoreAsc"   = pure ScoreAsc
 223     parseUrlPiece "ScoreDesc"  = pure ScoreDesc
 224     parseUrlPiece "SourceAsc"  = pure SourceAsc
 225     parseUrlPiece "SourceDesc" = pure SourceDesc
 226     parseUrlPiece _            = Left "Unexpected value of OrderBy"
 227
 228 instance ToParamSchema OrderBy
 229 instance FromJSON  OrderBy
 230 instance ToJSON    OrderBy
 231 instance ToSchema  OrderBy
 232 instance Arbitrary OrderBy
 233   where
 234     arbitrary = elements [minBound..maxBound]
 235
 236
 237 -- TODO-SECURITY check
 238
 239 --{-
 240 runViewAuthorsDoc :: HasDBid NodeType
 241                   => ContactId
 242                   -> IsTrash
 243                   -> Maybe Offset
 244                   -> Maybe Limit
 245                   -> Maybe OrderBy
 246                   -> Cmd err [FacetDoc]
 247 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
 248   where
 249     ntId = NodeDocument
 250
 251 -- TODO add delete ?
 252 viewAuthorsDoc :: HasDBid NodeType
 253                => ContactId
 254                -> IsTrash
 255                -> NodeType
 256                -> Query FacetDocRead
 257 viewAuthorsDoc cId _ nt = proc () -> do
 258   (doc,(_,(_,(_,contact')))) <- queryAuthorsDoc      -< ()
 259
 260   {-nn         <- queryNodeNodeTable -< ()
 261   restrict -< nn_node1_id nn .== _node_id doc
 262   -- restrict -< nn_delete   nn .== (pgBool t)
 263   -}
 264
 265   restrict -< _node_id   contact'  .== (toNullable $ pgNodeId cId)
 266   restrict -< _node_typename doc   .== (pgInt4 $ toDBid nt)
 267
 268   returnA  -< FacetDoc (_node_id        doc)
 269                        (_node_date      doc)
 270                        (_node_name      doc)
 271                        (_node_hyperdata doc)
 272                        (toNullable $ pgInt4 1)
 273                        (toNullable $ pgDouble 1)
 274                        (toNullable $ pgDouble 1)
 275
 276 queryAuthorsDoc :: Query (NodeRead, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull))))
 277 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNodeNgramsTable queryNgramsTable queryNodeNodeNgramsTable queryNodeTable cond12 cond23 cond34 cond45
 278     where
 279          cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
 280          cond12 (nodeNgram, doc) =  _node_id                  doc
 281                                 .== _nnng_node1_id nodeNgram
 282
 283          cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
 284          cond23 (ngrams', (nodeNgram, _)) =  ngrams'^.ngrams_id
 285                                         .== _nnng_ngrams_id nodeNgram
 286
 287          cond34 :: (NodeNodeNgramsRead, (NgramsRead, (NodeNodeNgramsReadNull, NodeReadNull))) -> Column PGBool
 288          cond34 (nodeNgram2, (ngrams', (_,_)))= ngrams'^.ngrams_id .== _nnng_ngrams_id       nodeNgram2
 289
 290          cond45 :: (NodeRead, (NodeNodeNgramsRead, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))) -> Column PGBool
 291          cond45 (contact', (nodeNgram2', (_, (_,_)))) = _node_id  contact'  .== _nnng_node1_id         nodeNgram2'
 292
 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     runOpaQuery $ filterWith o l order sqlQuery
 307   where
 308     ntId = toDBid NodeDocument
 309     sqlQuery = viewDocuments cId t ntId 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               -> Query FacetDocRead
 323 viewDocuments cId t ntId mQuery = proc () -> do
 324   n  <- queryNodeTable     -< ()
 325   nn <- queryNodeNodeTable -< ()
 326   restrict -< n^.node_id       .== nn^.nn_node2_id
 327   restrict -< nn^.nn_node1_id  .== (pgNodeId cId)
 328   restrict -< n^.node_typename .== (pgInt4 ntId)
 329   restrict -< if t then nn^.nn_category .== (pgInt4 0)
 330                    else nn^.nn_category .>= (pgInt4 1)
 331
 332   let query = (fromMaybe "" mQuery)
 333       iLikeQuery = T.intercalate "" ["%", query, "%"]
 334   restrict -< (n^.node_name) `ilike` (pgStrictText iLikeQuery)
 335
 336   returnA  -< FacetDoc (_node_id        n)
 337                        (_node_date      n)
 338                        (_node_name      n)
 339                        (_node_hyperdata n)
 340                        (toNullable $ nn^.nn_category)
 341                        (toNullable $ nn^.nn_score)
 342                        (toNullable $ nn^.nn_score)
 343
 344 ------------------------------------------------------------------------
 345 filterWith :: (PGOrd date, PGOrd title, PGOrd category, PGOrd score, hyperdata ~ Column SqlJsonb) =>
 346         Maybe Gargantext.Core.Types.Offset
 347      -> Maybe Gargantext.Core.Types.Limit
 348      -> Maybe OrderBy
 349      -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
 350      -> Select (Facet id (Column date) (Column title) hyperdata (Column category) ngramCount (Column score))
 351 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
 352
 353
 354 orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3, PGOrd b4)
 355           => Maybe OrderBy
 356           -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) ngramCount (Column b4))
 357 orderWith (Just DateAsc)   = asc  facetDoc_created
 358 orderWith (Just DateDesc)  = desc facetDoc_created
 359
 360 orderWith (Just TitleAsc)  = asc  facetDoc_title
 361 orderWith (Just TitleDesc) = desc facetDoc_title
 362
 363 orderWith (Just ScoreAsc)  = asc  facetDoc_score
 364 orderWith (Just ScoreDesc) = descNullsLast facetDoc_score
 365
 366 orderWith (Just SourceAsc)  = asc  facetDoc_source
 367 orderWith (Just SourceDesc) = desc facetDoc_source
 368
 369 orderWith _                = asc facetDoc_created
 370
 371 facetDoc_source :: PGIsJson a
 372                 => Facet id created title (Column a) favorite ngramCount score
 373                 -> Column (Nullable PGText)
 374 facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> pgString "source"