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   <- hyperdataDocuments
 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 data FacetChart = FacetChart { facetChart_time  :: UTCTime'
 171                              , facetChart_count :: Double
 172                         }
 173         deriving (Show, Generic)
 174 $(deriveJSON (unPrefix "facetChart_") ''FacetChart)
 175 instance ToSchema FacetChart
 176
 177 instance Arbitrary FacetChart where
 178     arbitrary = FacetChart <$> arbitrary <*> arbitrary
 179
 180 -----------------------------------------------------------------------
 181 type Trash   = Bool
 182 data OrderBy =  DateAsc   | DateDesc
 183              | TitleAsc   | TitleDesc
 184              | ScoreDesc  | ScoreAsc
 185              deriving (Generic, Enum, Bounded, Read, Show)
 186              -- | NgramCoun
 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 _           = Left "Unexpected value of OrderBy"
 197
 198 instance ToParamSchema OrderBy
 199 instance FromJSON  OrderBy
 200 instance ToJSON    OrderBy
 201 instance ToSchema  OrderBy
 202 instance Arbitrary OrderBy
 203   where
 204     arbitrary = elements [minBound..maxBound]
 205
 206
 207 runViewAuthorsDoc :: ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
 208 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
 209   where
 210     ntId = NodeDocument
 211
 212 -- TODO add delete ?
 213 viewAuthorsDoc :: ContactId -> Trash -> NodeType -> Query FacetDocRead
 214 viewAuthorsDoc cId _ nt = proc () -> do
 215   (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc      -< ()
 216
 217   {-nn         <- queryNodeNodeTable -< ()
 218   restrict -< nodeNode_node1_id nn .== _node_id doc
 219   -- restrict -< nodeNode_delete   nn .== (pgBool t)
 220   -}
 221
 222   restrict -< _node_id   contact   .== (toNullable $ pgInt4 cId)
 223   restrict -< _node_typename doc   .== (pgInt4 $ nodeTypeId nt)
 224
 225   returnA  -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
 226
 227 queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
 228 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
 229     where
 230          cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
 231          cond12 (nodeNgram, doc) =  _node_id                  doc
 232                                 .== nodeNgram_node_id nodeNgram
 233
 234          cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
 235          cond23 (ngrams, (nodeNgram, _)) =  ngrams_id                  ngrams
 236                                         .== nodeNgram_ngrams_id nodeNgram
 237
 238          cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
 239          cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams     .== nodeNgram_ngrams_id       nodeNgram2
 240
 241          cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
 242          cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== nodeNgram_node_id         nodeNgram2
 243
 244
 245 ------------------------------------------------------------------------
 246
 247 runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
 248 runViewDocuments cId t o l order =
 249     runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
 250   where
 251     ntId = nodeTypeId NodeDocument
 252
 253 viewDocuments :: CorpusId -> Trash -> NodeTypeId -> Query FacetDocRead
 254 viewDocuments cId t ntId = proc () -> do
 255   n  <- queryNodeTable     -< ()
 256   nn <- queryNodeNodeTable -< ()
 257   restrict -< _node_id          n  .== nodeNode_node2_id nn
 258   restrict -< nodeNode_node1_id nn .== (pgInt4 cId)
 259   restrict -< _node_typename    n  .== (pgInt4 ntId)
 260   restrict -< nodeNode_delete   nn .== (pgBool t)
 261   returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nodeNode_favorite nn) (pgInt4 1)
 262
 263
 264 ------------------------------------------------------------------------
 265 filterWith :: (PGOrd date, PGOrd title, PGOrd score) =>
 266      Maybe Gargantext.Core.Types.Offset
 267      -> Maybe Gargantext.Core.Types.Limit
 268      -> Maybe OrderBy
 269      -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
 270      -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
 271 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
 272
 273
 274 orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3) => Maybe OrderBy -> Order (Facet id (Column b1) (Column b2) hyperdata (Column b3) score)
 275 orderWith order = case order of
 276   (Just DateAsc)   -> asc  facetDoc_created
 277
 278   (Just TitleAsc)  -> asc  facetDoc_title
 279   (Just TitleDesc) -> desc facetDoc_title
 280
 281   (Just ScoreAsc)  -> asc  facetDoc_favorite
 282   (Just ScoreDesc) -> desc facetDoc_favorite
 283   _                -> desc facetDoc_created
 284