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