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 Data.Text (Text)
  46 import Data.Time (UTCTime)
  47 import Data.Time.Segment (jour)
  48 import Data.Typeable (Typeable)
  49 import GHC.Generics (Generic)
  50 import Opaleye
  51 import Prelude hiding (null, id, map, sum, not, read)
  52 import Servant.API
  53 import Test.QuickCheck (elements)
  54 import Test.QuickCheck.Arbitrary
  55 import qualified Opaleye.Internal.Unpackspec()
  56
  57 import Gargantext.Core.Types
  58 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
  59 import Gargantext.Database.Admin.Config (nodeTypeId)
  60 import Gargantext.Database.Admin.Types.Hyperdata
  61 import Gargantext.Database.Query.Filter
  62 import Gargantext.Database.Query.Join (leftJoin5)
  63 import Gargantext.Database.Query.Table.Ngrams
  64 import Gargantext.Database.Query.Table.NodeNode
  65 import Gargantext.Database.Query.Table.NodeNodeNgrams
  66 import Gargantext.Database.Prelude
  67 import Gargantext.Database.Schema.Node
  68
  69 ------------------------------------------------------------------------
  70 -- | DocFacet
  71
  72 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
  73 --    deriving (Show, Generic)
  74 --instance FromJSON Facet
  75 --instance ToJSON   Facet
  76
  77 type Category = Int
  78 type Title    = Text
  79
  80 -- TODO remove Title
  81 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Category) (Maybe Double)
  82 -- type FacetSources = FacetDoc
  83 -- type FacetAuthors = FacetDoc
  84 -- type FacetTerms   = FacetDoc
  85
  86
  87 data Facet id created title hyperdata category ngramCount =
  88      FacetDoc { facetDoc_id         :: id
  89               , facetDoc_created    :: created
  90               , facetDoc_title      :: title
  91               , facetDoc_hyperdata  :: hyperdata
  92               , facetDoc_category   :: category
  93               , facetDoc_score      :: ngramCount
  94               } deriving (Show, Generic)
  95 {- | TODO after demo
  96 data Facet id date hyperdata score =
  97      FacetDoc { facetDoc_id        :: id
  98               , facetDoc_date      :: date
  99               , facetDoc_hyperdata :: hyperdata
 100               , facetDoc_score     :: score
 101               } deriving (Show, Generic)
 102 -}
 103
 104 data Pair i l = Pair {_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)
 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                          ]
 188
 189 -- Facets / Views for the Front End
 190 -- | Database instances
 191 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
 192 -- $(makeLensesWith abbreviatedFields   ''Facet)
 193
 194 type FacetDocRead = Facet (Column PGInt4       )
 195                           (Column PGTimestamptz)
 196                           (Column PGText       )
 197                           (Column PGJsonb      )
 198                           (Column (Nullable PGInt4)) -- Category
 199                           (Column (Nullable PGFloat8)) -- Score
 200
 201 -----------------------------------------------------------------------
 202 -----------------------------------------------------------------------
 203 data OrderBy =  DateAsc   | DateDesc
 204              | TitleAsc   | TitleDesc
 205              | ScoreDesc  | ScoreAsc
 206              | SourceAsc  | SourceDesc
 207              deriving (Generic, Enum, Bounded, Read, Show)
 208
 209 instance FromHttpApiData OrderBy
 210   where
 211     parseUrlPiece "DateAsc"    = pure DateAsc
 212     parseUrlPiece "DateDesc"   = pure DateDesc
 213     parseUrlPiece "TitleAsc"   = pure TitleAsc
 214     parseUrlPiece "TitleDesc"  = pure TitleDesc
 215     parseUrlPiece "ScoreAsc"   = pure ScoreAsc
 216     parseUrlPiece "ScoreDesc"  = pure ScoreDesc
 217     parseUrlPiece "SourceAsc"  = pure SourceAsc
 218     parseUrlPiece "SourceDesc" = pure SourceDesc
 219     parseUrlPiece _            = Left "Unexpected value of OrderBy"
 220
 221 instance ToParamSchema OrderBy
 222 instance FromJSON  OrderBy
 223 instance ToJSON    OrderBy
 224 instance ToSchema  OrderBy
 225 instance Arbitrary OrderBy
 226   where
 227     arbitrary = elements [minBound..maxBound]
 228
 229
 230 -- TODO-SECURITY check
 231
 232 --{-
 233 runViewAuthorsDoc :: ContactId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
 234 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
 235   where
 236     ntId = NodeDocument
 237
 238 -- TODO add delete ?
 239 viewAuthorsDoc :: ContactId -> IsTrash -> NodeType -> Query FacetDocRead
 240 viewAuthorsDoc cId _ nt = proc () -> do
 241   (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc      -< ()
 242
 243   {-nn         <- queryNodeNodeTable -< ()
 244   restrict -< nn_node1_id nn .== _node_id doc
 245   -- restrict -< nn_delete   nn .== (pgBool t)
 246   -}
 247
 248   restrict -< _node_id   contact   .== (toNullable $ pgNodeId cId)
 249   restrict -< _node_typename doc   .== (pgInt4 $ nodeTypeId nt)
 250
 251   returnA  -< FacetDoc (_node_id        doc)
 252                        (_node_date      doc)
 253                        (_node_name      doc)
 254                        (_node_hyperdata doc)
 255                        (toNullable $ pgInt4 1)
 256                        (toNullable $ pgDouble 1)
 257
 258 queryAuthorsDoc :: Query (NodeRead, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull))))
 259 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNodeNgramsTable queryNgramsTable queryNodeNodeNgramsTable queryNodeTable cond12 cond23 cond34 cond45
 260     where
 261          cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
 262          cond12 (nodeNgram, doc) =  _node_id                  doc
 263                                 .== _nnng_node1_id nodeNgram
 264
 265          cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
 266          cond23 (ngrams, (nodeNgram, _)) =  ngrams^.ngrams_id
 267                                         .== _nnng_ngrams_id nodeNgram
 268
 269          cond34 :: (NodeNodeNgramsRead, (NgramsRead, (NodeNodeNgramsReadNull, NodeReadNull))) -> Column PGBool
 270          cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams^.ngrams_id .== _nnng_ngrams_id       nodeNgram2
 271
 272          cond45 :: (NodeRead, (NodeNodeNgramsRead, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))) -> Column PGBool
 273          cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== _nnng_node1_id         nodeNgram2
 274
 275 --}
 276 ------------------------------------------------------------------------
 277
 278 -- TODO-SECURITY check
 279 runViewDocuments :: CorpusId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
 280 runViewDocuments cId t o l order =
 281     runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
 282   where
 283     ntId = nodeTypeId NodeDocument
 284
 285 runCountDocuments :: CorpusId -> IsTrash -> Cmd err Int
 286 runCountDocuments cId t  =
 287   runCountOpaQuery $ viewDocuments cId t $ nodeTypeId NodeDocument
 288
 289
 290 viewDocuments :: CorpusId -> IsTrash -> NodeTypeId -> Query FacetDocRead
 291 viewDocuments cId t ntId = proc () -> do
 292   n  <- queryNodeTable     -< ()
 293   nn <- queryNodeNodeTable -< ()
 294   restrict -< n^.node_id       .== nn^.nn_node2_id
 295   restrict -< nn^.nn_node1_id  .== (pgNodeId cId)
 296   restrict -< n^.node_typename .== (pgInt4 ntId)
 297   restrict -< if t then nn^.nn_category .== (pgInt4 0)
 298                    else nn^.nn_category .>= (pgInt4 1)
 299   returnA  -< FacetDoc (_node_id        n)
 300                        (_node_date      n)
 301                        (_node_name      n)
 302                        (_node_hyperdata n)
 303                        (toNullable $ nn^.nn_category)
 304                        (toNullable $ nn^.nn_score)
 305
 306 ------------------------------------------------------------------------
 307 filterWith :: (PGOrd date, PGOrd title, PGOrd score, hyperdata ~ Column SqlJsonb) =>
 308      Maybe Gargantext.Core.Types.Offset
 309      -> Maybe Gargantext.Core.Types.Limit
 310      -> Maybe OrderBy
 311      -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
 312      -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
 313 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
 314
 315
 316 orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3)
 317           => Maybe OrderBy
 318           -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) score)
 319 orderWith (Just DateAsc)   = asc  facetDoc_created
 320 orderWith (Just DateDesc)  = desc facetDoc_created
 321
 322 orderWith (Just TitleAsc)  = asc  facetDoc_title
 323 orderWith (Just TitleDesc) = desc facetDoc_title
 324
 325 orderWith (Just ScoreAsc)  = asc  facetDoc_category
 326 orderWith (Just ScoreDesc) = desc facetDoc_category
 327
 328 orderWith (Just SourceAsc)  = asc  facetDoc_source
 329 orderWith (Just SourceDesc) = desc facetDoc_source
 330
 331 orderWith _                = asc facetDoc_created
 332
 333 facetDoc_source :: PGIsJson a
 334                 => Facet id created title (Column a) favorite ngramCount
 335                 -> Column (Nullable PGText)
 336 facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> pgString "source"