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