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