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 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument Favorite Int
  72 type FacetSources = FacetDoc
  73 type FacetAuthors = FacetDoc
  74 type FacetTerms   = FacetDoc
  75
  76
  77 data Facet id created title hyperdata favorite ngramCount =
  78      FacetDoc { facetDoc_id         :: id
  79               , facetDoc_created    :: created
  80               , facetDoc_title      :: title
  81               , facetDoc_hyperdata  :: hyperdata
  82               , facetDoc_favorite   :: favorite
  83               , facetDoc_ngramCount :: ngramCount
  84               } deriving (Show, Generic)
  85 {- | TODO after demo
  86 data Facet id date hyperdata score =
  87      FacetDoc { facetDoc_id        :: id
  88               , facetDoc_date      :: date
  89               , facetDoc_hyperdata :: hyperdata
  90               , facetDoc_score     :: score
  91               } deriving (Show, Generic)
  92 -}
  93
  94 data Pair i l = Pair {_p_id    :: i
  95                      ,_p_label :: l
  96   } deriving (Show, Generic)
  97 $(deriveJSON (unPrefix "_p_") ''Pair)
  98 $(makeAdaptorAndInstance "pPair" ''Pair)
  99
 100 instance (ToSchema i, ToSchema l) => ToSchema (Pair i l) where
 101   declareNamedSchema =
 102     genericDeclareNamedSchema
 103       defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 3 fieldLabel}
 104 instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
 105   arbitrary = Pair <$> arbitrary <*> arbitrary
 106
 107 data FacetPaired id date hyperdata score pairs =
 108   FacetPaired {_fp_id        :: id
 109               ,_fp_date      :: date
 110               ,_fp_hyperdata :: hyperdata
 111               ,_fp_score     :: score
 112               ,_fp_pairs     :: pairs
 113   } deriving (Show, Generic)
 114 $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
 115 $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
 116
 117 instance (ToSchema id, ToSchema date, ToSchema hyperdata, ToSchema pairs, ToSchema score) => ToSchema (FacetPaired id date hyperdata score pairs) where
 118   declareNamedSchema =
 119     genericDeclareNamedSchema
 120       defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
 121
 122 instance ( Arbitrary id
 123          , Arbitrary date
 124          , Arbitrary hyperdata
 125          , Arbitrary score
 126          , Arbitrary pairs
 127          ) => Arbitrary (FacetPaired id date hyperdata score pairs) where
 128   arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 129
 130 --{-
 131 type FacetPairedRead = FacetPaired (Column PGInt4       )
 132                                    (Column PGTimestamptz)
 133                                    (Column PGJsonb      )
 134                                    (Column PGInt4       )
 135                                    (Pair (Column (Nullable PGInt4)) (Column (Nullable PGText)))
 136 --}
 137
 138
 139
 140 -- | JSON instance
 141 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
 142
 143 -- | Documentation instance
 144 instance ToSchema FacetDoc
 145
 146 -- | Mock and Quickcheck instances
 147 instance Arbitrary FacetDoc where
 148     arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp fav ngramCount
 149                          | id'  <- [1..10]
 150                          , year <- [1990..2000]
 151                          , t    <- ["title", "another title"]
 152                          , hp   <- arbitraryHyperdataDocuments
 153                          , fav  <- [True, False]
 154                          , ngramCount <- [3..100]
 155                          ]
 156
 157 -- Facets / Views for the Front End
 158 -- | Database instances
 159 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
 160 $(makeLensesWith abbreviatedFields   ''Facet)
 161
 162 type FacetDocRead = Facet (Column PGInt4       )
 163                           (Column PGTimestamptz)
 164                           (Column PGText       )
 165                           (Column PGJsonb      )
 166                           (Column PGBool)
 167                           (Column PGInt4       )
 168
 169 -----------------------------------------------------------------------
 170 -----------------------------------------------------------------------
 171 type Trash   = Bool
 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 -> Trash -> 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 -> Trash -> 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) (pgBool True) (pgInt4 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 -> Trash -> 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 -> Trash -> 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 -< nn_delete      nn .== (pgBool t)
 253   returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nn_favorite nn) (pgInt4 1)
 254
 255
 256 ------------------------------------------------------------------------
 257 filterWith :: (PGOrd date, PGOrd title, PGOrd score, hyperdata ~ Column SqlJsonb) =>
 258      Maybe Gargantext.Core.Types.Offset
 259      -> Maybe Gargantext.Core.Types.Limit
 260      -> Maybe OrderBy
 261      -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
 262      -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
 263 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
 264
 265
 266 orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3)
 267           => Maybe OrderBy
 268           -> Order (Facet id (Column b1) (Column b2) (Column SqlJsonb) (Column b3) score)
 269 orderWith (Just DateAsc)   = asc  facetDoc_created
 270 orderWith (Just DateDesc)  = desc facetDoc_created
 271
 272 orderWith (Just TitleAsc)  = asc  facetDoc_title
 273 orderWith (Just TitleDesc) = desc facetDoc_title
 274
 275 orderWith (Just ScoreAsc)  = asc  facetDoc_favorite
 276 orderWith (Just ScoreDesc) = desc facetDoc_favorite
 277
 278 orderWith (Just SourceAsc)  = asc  facetDoc_source
 279 orderWith (Just SourceDesc) = desc facetDoc_source
 280
 281 orderWith _                = asc facetDoc_created
 282
 283 facetDoc_source :: PGIsJson a
 284                 => Facet id created title (Column a) favorite ngramCount
 285                 -> Column (Nullable PGText)
 286 facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> pgString "source"