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