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