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              -- | NgramCoun
 176
 177 instance FromHttpApiData OrderBy
 178   where
 179     parseUrlPiece "DateAsc"  = pure DateAsc
 180     parseUrlPiece "DateDesc" = pure DateDesc
 181     parseUrlPiece "TitleAsc" = pure TitleAsc
 182     parseUrlPiece "TitleDesc" = pure TitleDesc
 183     parseUrlPiece "ScoreAsc"   = pure ScoreAsc
 184     parseUrlPiece "ScoreDesc"  = pure ScoreDesc
 185     parseUrlPiece _           = Left "Unexpected value of OrderBy"
 186
 187 instance ToParamSchema OrderBy
 188 instance FromJSON  OrderBy
 189 instance ToJSON    OrderBy
 190 instance ToSchema  OrderBy
 191 instance Arbitrary OrderBy
 192   where
 193     arbitrary = elements [minBound..maxBound]
 194
 195
 196 runViewAuthorsDoc :: ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
 197 runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
 198   where
 199     ntId = NodeDocument
 200
 201 -- TODO add delete ?
 202 viewAuthorsDoc :: ContactId -> Trash -> NodeType -> Query FacetDocRead
 203 viewAuthorsDoc cId _ nt = proc () -> do
 204   (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc      -< ()
 205
 206   {-nn         <- queryNodeNodeTable -< ()
 207   restrict -< nn_node1_id nn .== _node_id doc
 208   -- restrict -< nn_delete   nn .== (pgBool t)
 209   -}
 210
 211   restrict -< _node_id   contact   .== (toNullable $ pgNodeId cId)
 212   restrict -< _node_typename doc   .== (pgInt4 $ nodeTypeId nt)
 213
 214   returnA  -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
 215
 216 queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
 217 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
 218     where
 219          cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
 220          cond12 (nodeNgram, doc) =  _node_id                  doc
 221                                 .== nng_node_id nodeNgram
 222
 223          cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
 224          cond23 (ngrams, (nodeNgram, _)) =  ngrams_id                  ngrams
 225                                         .== nng_ngrams_id nodeNgram
 226
 227          cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
 228          cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams     .== nng_ngrams_id       nodeNgram2
 229
 230          cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
 231          cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== nng_node_id         nodeNgram2
 232
 233
 234 ------------------------------------------------------------------------
 235
 236 runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
 237 runViewDocuments cId t o l order =
 238     runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
 239   where
 240     ntId = nodeTypeId NodeDocument
 241
 242 viewDocuments :: CorpusId -> Trash -> NodeTypeId -> Query FacetDocRead
 243 viewDocuments cId t ntId = proc () -> do
 244   n  <- queryNodeTable     -< ()
 245   nn <- queryNodeNodeTable -< ()
 246   restrict -< _node_id        n .== nn_node2_id nn
 247   restrict -< nn_node1_id    nn .== (pgNodeId cId)
 248   restrict -< _node_typename  n .== (pgInt4 ntId)
 249   restrict -< nn_delete      nn .== (pgBool t)
 250   returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nn_favorite nn) (pgInt4 1)
 251
 252
 253 ------------------------------------------------------------------------
 254 filterWith :: (PGOrd date, PGOrd title, PGOrd score) =>
 255      Maybe Gargantext.Core.Types.Offset
 256      -> Maybe Gargantext.Core.Types.Limit
 257      -> Maybe OrderBy
 258      -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
 259      -> Select (Facet id (Column date) (Column title) hyperdata (Column score) ngramCount)
 260 filterWith o l order q = limit' l $ offset' o $ orderBy (orderWith order) q
 261
 262
 263 orderWith :: (PGOrd b1, PGOrd b2, PGOrd b3) => Maybe OrderBy -> Order (Facet id (Column b1) (Column b2) hyperdata (Column b3) score)
 264 orderWith order = case order of
 265   (Just DateAsc)   -> asc  facetDoc_created
 266
 267   (Just TitleAsc)  -> asc  facetDoc_title
 268   (Just TitleDesc) -> desc facetDoc_title
 269
 270   (Just ScoreAsc)  -> asc  facetDoc_favorite
 271   (Just ScoreDesc) -> desc facetDoc_favorite
 272   _                -> desc facetDoc_created
 273