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