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