src/Gargantext/Database/Query/Facet.hs

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