src/Gargantext/Database/Facet.hs

   1 {-|
   2 Module      : Gargantext.Database.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.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.TH (makeLensesWith, abbreviatedFields)
  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.Config (nodeTypeId)
  58 import Gargantext.Database.Schema.Ngrams
  59 import Gargantext.Database.Schema.Node
  60 import Gargantext.Database.Schema.NodeNgram
  61 import Gargantext.Database.Schema.NodeNode
  62 import Gargantext.Database.Utils
  63 import Gargantext.Database.Queries.Join
  64 import Gargantext.Database.Queries.Filter
  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 pairs =
 119   FacetPaired {_fp_id        :: id
 120               ,_fp_date      :: date
 121               ,_fp_hyperdata :: hyperdata
 122               ,_fp_score     :: score
 123               ,_fp_pairs     :: pairs
 124   } deriving (Show, Generic)
 125 $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
 126 $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
 127
 128 instance (ToSchema id, ToSchema date, ToSchema hyperdata, ToSchema pairs, ToSchema score) => ToSchema (FacetPaired id date hyperdata score pairs) where
 129   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fp_")
 130
 131 instance ( Arbitrary id
 132          , Arbitrary date
 133          , Arbitrary hyperdata
 134          , Arbitrary score
 135          , Arbitrary pairs
 136          ) => Arbitrary (FacetPaired id date hyperdata score pairs) where
 137   arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 138
 139 --{-
 140 type FacetPairedRead = FacetPaired (Column PGInt4       )
 141                                    (Column PGTimestamptz)
 142                                    (Column PGJsonb      )
 143                                    (Column PGInt4       )
 144                                    (Pair (Column (Nullable PGInt4)) (Column (Nullable PGText)))
 145 --}
 146
 147
 148
 149 -- | JSON instance
 150 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
 151
 152 -- | Documentation instance
 153 instance ToSchema FacetDoc where
 154   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "facetDoc_")
 155
 156 -- | Mock and Quickcheck instances
 157 instance Arbitrary FacetDoc where
 158     arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp (Just cat) (Just ngramCount)
 159                          | id'  <- [1..10]
 160                          , year <- [1990..2000]
 161                          , t    <- ["title", "another title"]
 162                          , hp   <- arbitraryHyperdataDocuments
 163                          , cat  <- [0..2]
 164                          , ngramCount <- [3..100]
 165                          ]
 166
 167 -- Facets / Views for the Front End
 168 -- | Database instances
 169 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
 170 -- $(makeLensesWith abbreviatedFields   ''Facet)
 171
 172 type FacetDocRead = Facet (Column PGInt4       )
 173                           (Column PGTimestamptz)
 174                           (Column PGText       )
 175                           (Column PGJsonb      )
 176                           (Column (Nullable PGInt4)) -- Category
 177                           (Column (Nullable PGFloat8)) -- Score
 178
 179 -----------------------------------------------------------------------
 180 -----------------------------------------------------------------------
 181 data OrderBy =  DateAsc   | DateDesc
 182              | TitleAsc   | TitleDesc
 183              | ScoreDesc  | ScoreAsc
 184              | SourceAsc  | SourceDesc
 185              deriving (Generic, Enum, Bounded, Read, Show)
 186
 187 instance FromHttpApiData OrderBy
 188   where
 189     parseUrlPiece "DateAsc"    = pure DateAsc
 190     parseUrlPiece "DateDesc"   = pure DateDesc
 191     parseUrlPiece "TitleAsc"   = pure TitleAsc
 192     parseUrlPiece "TitleDesc"  = pure TitleDesc
 193     parseUrlPiece "ScoreAsc"   = pure ScoreAsc
 194     parseUrlPiece "ScoreDesc"  = pure ScoreDesc
 195     parseUrlPiece "SourceAsc"  = pure SourceAsc
 196     parseUrlPiece "SourceDesc" = pure SourceDesc
 197     parseUrlPiece _            = Left "Unexpected value of OrderBy"
 198
 199 instance ToParamSchema OrderBy
 200 instance FromJSON  OrderBy
 201 instance ToJSON    OrderBy
 202 instance ToSchema  OrderBy
 203 instance Arbitrary OrderBy
 204   where
 205     arbitrary = elements [minBound..maxBound]
 206
 207
 208 -- TODO-SECURITY check
 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) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (toNullable $ pgInt4 1) (toNullable $ pgDouble 1)
 228
 229 queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
 230 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
 231     where
 232          cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
 233          cond12 (nodeNgram, doc) =  _node_id                  doc
 234                                 .== nng_node_id nodeNgram
 235
 236          cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
 237          cond23 (ngrams, (nodeNgram, _)) =  ngrams_id                  ngrams
 238                                         .== nng_ngrams_id nodeNgram
 239
 240          cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
 241          cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams     .== nng_ngrams_id       nodeNgram2
 242
 243          cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
 244          cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== nng_node_id         nodeNgram2
 245
 246
 247 ------------------------------------------------------------------------
 248
 249 -- TODO-SECURITY check
 250 runViewDocuments :: CorpusId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
 251 runViewDocuments cId t o l order =
 252     runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
 253   where
 254     ntId = nodeTypeId NodeDocument
 255
 256 viewDocuments :: CorpusId -> IsTrash -> NodeTypeId -> Query FacetDocRead
 257 viewDocuments cId t ntId = proc () -> do
 258   n  <- queryNodeTable     -< ()
 259   nn <- queryNodeNodeTable -< ()
 260   restrict -< _node_id        n .== nn_node2_id nn
 261   restrict -< nn_node1_id    nn .== (pgNodeId cId)
 262   restrict -< _node_typename  n .== (pgInt4 ntId)
 263   restrict -< if t then nn_category  nn .== (pgInt4 0)
 264                    else nn_category  nn .>= (pgInt4 1)
 265   returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (toNullable $ nn_category nn) (toNullable $ nn_score nn)
 266
 267
 268 ------------------------------------------------------------------------
 269 filterWith :: (PGOrd date, PGOrd title, PGOrd score, hyperdata ~ Column SqlJsonb) =>
 270      Maybe Gargantext.Core.Types.Offset
 271      -> Maybe Gargantext.Core.Types.Limit
 272      -> Maybe OrderBy
 273      -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
 274      -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
 275 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
 276
 277
 278 orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3)
 279           => Maybe OrderBy
 280           -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) score)
 281 orderWith (Just DateAsc)   = asc  facetDoc_created
 282 orderWith (Just DateDesc)  = desc facetDoc_created
 283
 284 orderWith (Just TitleAsc)  = asc  facetDoc_title
 285 orderWith (Just TitleDesc) = desc facetDoc_title
 286
 287 orderWith (Just ScoreAsc)  = asc  facetDoc_favorite
 288 orderWith (Just ScoreDesc) = desc facetDoc_favorite
 289
 290 orderWith (Just SourceAsc)  = asc  facetDoc_source
 291 orderWith (Just SourceDesc) = desc facetDoc_source
 292
 293 orderWith _                = asc facetDoc_created
 294
 295 facetDoc_source :: PGIsJson a
 296                 => Facet id created title (Column a) favorite ngramCount
 297                 -> Column (Nullable PGText)
 298 facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> pgString "source"