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 = Bool
  69 type Title    = Text
  70
  71 -- TODO remove Title
  72 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument Favorite Int
  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 fav ngramCount
 150                          | id'  <- [1..10]
 151                          , year <- [1990..2000]
 152                          , t    <- ["title", "another title"]
 153                          , hp   <- arbitraryHyperdataDocuments
 154                          , fav  <- [True, False]
 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 PGBool)
 168                           (Column PGInt4       )
 169
 170 -----------------------------------------------------------------------
 171 -----------------------------------------------------------------------
 172 type Trash   = Bool
 173 data OrderBy =  DateAsc   | DateDesc
 174              | TitleAsc   | TitleDesc
 175              | ScoreDesc  | ScoreAsc
 176              | SourceAsc  | SourceDesc
 177              deriving (Generic, Enum, Bounded, Read, Show)
 178
 179 instance FromHttpApiData OrderBy
 180   where
 181     parseUrlPiece "DateAsc"    = pure DateAsc
 182     parseUrlPiece "DateDesc"   = pure DateDesc
 183     parseUrlPiece "TitleAsc"   = pure TitleAsc
 184     parseUrlPiece "TitleDesc"  = pure TitleDesc
 185     parseUrlPiece "ScoreAsc"   = pure ScoreAsc
 186     parseUrlPiece "ScoreDesc"  = pure ScoreDesc
 187     parseUrlPiece "SourceAsc"  = pure SourceAsc
 188     parseUrlPiece "SourceDesc" = pure SourceDesc
 189     parseUrlPiece _            = Left "Unexpected value of OrderBy"
 190
 191 instance ToParamSchema OrderBy
 192 instance FromJSON  OrderBy
 193 instance ToJSON    OrderBy
 194 instance ToSchema  OrderBy
 195 instance Arbitrary OrderBy
 196   where
 197     arbitrary = elements [minBound..maxBound]
 198
 199
 200 runViewAuthorsDoc :: ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
 201 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
 202   where
 203     ntId = NodeDocument
 204
 205 -- TODO add delete ?
 206 viewAuthorsDoc :: ContactId -> Trash -> NodeType -> Query FacetDocRead
 207 viewAuthorsDoc cId _ nt = proc () -> do
 208   (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc      -< ()
 209
 210   {-nn         <- queryNodeNodeTable -< ()
 211   restrict -< nn_node1_id nn .== _node_id doc
 212   -- restrict -< nn_delete   nn .== (pgBool t)
 213   -}
 214
 215   restrict -< _node_id   contact   .== (toNullable $ pgNodeId cId)
 216   restrict -< _node_typename doc   .== (pgInt4 $ nodeTypeId nt)
 217
 218   returnA  -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
 219
 220 queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
 221 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
 222     where
 223          cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
 224          cond12 (nodeNgram, doc) =  _node_id                  doc
 225                                 .== nng_node_id nodeNgram
 226
 227          cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
 228          cond23 (ngrams, (nodeNgram, _)) =  ngrams_id                  ngrams
 229                                         .== nng_ngrams_id nodeNgram
 230
 231          cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
 232          cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams     .== nng_ngrams_id       nodeNgram2
 233
 234          cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
 235          cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== nng_node_id         nodeNgram2
 236
 237
 238 ------------------------------------------------------------------------
 239
 240 runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
 241 runViewDocuments cId t o l order =
 242     runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
 243   where
 244     ntId = nodeTypeId NodeDocument
 245
 246 viewDocuments :: CorpusId -> Trash -> NodeTypeId -> Query FacetDocRead
 247 viewDocuments cId t ntId = proc () -> do
 248   n  <- queryNodeTable     -< ()
 249   nn <- queryNodeNodeTable -< ()
 250   restrict -< _node_id        n .== nn_node2_id nn
 251   restrict -< nn_node1_id    nn .== (pgNodeId cId)
 252   restrict -< _node_typename  n .== (pgInt4 ntId)
 253   restrict -< nn_delete      nn .== (pgBool t)
 254   returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nn_favorite nn) (pgInt4 1)
 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"