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