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