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