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