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