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 TemplateHaskell           #-}
  25 ------------------------------------------------------------------------
  26 module Gargantext.Database.Facet
  27   where
  28 ------------------------------------------------------------------------
  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.Default
  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 Database.PostgreSQL.Simple (Connection)
  43 import GHC.Generics (Generic)
  44 import Gargantext.Core.Types
  45 import Gargantext.Core.Utils.Prefix (unPrefix)
  46 import Gargantext.Database.Config (nodeTypeId)
  47 import Gargantext.Database.Schema.Ngrams
  48 import Gargantext.Database.Schema.Node
  49 import Gargantext.Database.Schema.NodeNgram
  50 import Gargantext.Database.Schema.NodeNode
  51 import Gargantext.Database.Queries
  52 import Opaleye
  53 import Opaleye.Internal.Join (NullMaker(..))
  54 import Prelude (Enum, Bounded, minBound, maxBound)
  55 import Prelude hiding (null, id, map, sum, not, read)
  56 import Servant.API
  57 import Test.QuickCheck (elements)
  58 import Test.QuickCheck.Arbitrary
  59 import qualified Opaleye.Internal.Unpackspec()
  60
  61 ------------------------------------------------------------------------
  62 -- | DocFacet
  63
  64 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
  65 --    deriving (Show, Generic)
  66 --instance FromJSON Facet
  67 --instance ToJSON   Facet
  68
  69 type Favorite = Bool
  70 type Title    = Text
  71
  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
  79 data Facet id created title hyperdata favorite ngramCount =
  80      FacetDoc { facetDoc_id         :: id
  81               , facetDoc_created    :: created
  82               , facetDoc_title      :: title
  83               , facetDoc_hyperdata  :: hyperdata
  84               , facetDoc_favorite   :: favorite
  85               , facetDoc_ngramCount :: ngramCount
  86               } deriving (Show, Generic)
  87
  88 -- | JSON instance
  89
  90 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
  91
  92 -- | Documentation instance
  93 instance ToSchema FacetDoc
  94
  95 -- | Mock and Quickcheck instances
  96
  97 instance Arbitrary FacetDoc where
  98     arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp fav ngramCount
  99                          | id'  <- [1..10]
 100                          , year <- [1990..2000]
 101                          , t    <- ["title", "another title"]
 102                          , hp   <- hyperdataDocuments
 103                          , fav  <- [True, False]
 104                          , ngramCount <- [3..100]
 105                          ]
 106
 107 -- Facets / Views for the Front End
 108 -- | Database instances
 109 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
 110 $(makeLensesWith abbreviatedFields   ''Facet)
 111
 112 type FacetDocRead = Facet (Column PGInt4       )
 113                           (Column PGTimestamptz)
 114                           (Column PGText       )
 115                           (Column PGJsonb      )
 116                           (Column PGBool)
 117                           (Column PGInt4       )
 118
 119 -----------------------------------------------------------------------
 120
 121 data FacetChart = FacetChart { facetChart_time  :: UTCTime'
 122                              , facetChart_count :: Double
 123                         }
 124         deriving (Show, Generic)
 125 $(deriveJSON (unPrefix "facetChart_") ''FacetChart)
 126 instance ToSchema FacetChart
 127
 128 instance Arbitrary FacetChart where
 129     arbitrary = FacetChart <$> arbitrary <*> arbitrary
 130
 131 -----------------------------------------------------------------------
 132 type Trash   = Bool
 133 data OrderBy =  DateAsc | DateDesc
 134              | TitleAsc | TitleDesc
 135              | FavDesc  | FavAsc
 136              deriving (Generic, Enum, Bounded, Read, Show)
 137              -- | NgramCoun
 138
 139 instance FromHttpApiData OrderBy
 140   where
 141     parseUrlPiece "DateAsc"  = pure DateAsc
 142     parseUrlPiece "DateDesc" = pure DateDesc
 143     parseUrlPiece "TitleAsc" = pure TitleAsc
 144     parseUrlPiece "TitleDesc" = pure TitleDesc
 145     parseUrlPiece "FavAsc"   = pure FavAsc
 146     parseUrlPiece "FavDesc"   = pure FavDesc
 147     parseUrlPiece _           = Left "Unexpected value of OrderBy"
 148
 149 instance ToParamSchema OrderBy
 150 instance FromJSON  OrderBy
 151 instance ToJSON    OrderBy
 152 instance ToSchema  OrderBy
 153 instance Arbitrary OrderBy
 154   where
 155     arbitrary = elements [minBound..maxBound]
 156
 157
 158 runViewAuthorsDoc :: Connection -> ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
 159 runViewAuthorsDoc c cId t o l order = runQuery c (filterDocuments o l order $ viewAuthorsDoc cId t ntId)
 160   where
 161     ntId = NodeDocument
 162
 163 -- TODO add delete ?
 164 viewAuthorsDoc :: ContactId -> Trash -> NodeType -> Query FacetDocRead
 165 viewAuthorsDoc cId _ nt = proc () -> do
 166   (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc      -< ()
 167
 168   {-nn         <- queryNodeNodeTable -< ()
 169   restrict -< nodeNode_node1_id nn .== _node_id doc
 170   -- restrict -< nodeNode_delete   nn .== (pgBool t)
 171   -}
 172
 173   restrict -< _node_id   contact   .== (toNullable $ pgInt4 cId)
 174   restrict -< _node_typename doc   .== (pgInt4 $ nodeTypeId nt)
 175
 176   returnA  -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
 177
 178 queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
 179 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
 180     where
 181          cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
 182          cond12 (nodeNgram, doc) =  _node_id                  doc
 183                                 .== nodeNgram_NodeNgramNodeId nodeNgram
 184
 185          cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
 186          cond23 (ngrams, (nodeNgram, _)) =  ngrams_id                  ngrams
 187                                         .== nodeNgram_NodeNgramNgramId nodeNgram
 188
 189          cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
 190          cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams     .== nodeNgram_NodeNgramNgramId        nodeNgram2
 191
 192          cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
 193          cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== nodeNgram_NodeNgramNodeId         nodeNgram2
 194
 195
 196 ------------------------------------------------------------------------
 197
 198 runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd [FacetDoc]
 199 runViewDocuments cId t o l order = mkCmd $ \c -> runViewDocuments' c cId t o l order
 200
 201 -- | TODO use only Cmd with Reader and delete function below
 202 runViewDocuments' :: Connection -> CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
 203 runViewDocuments' c cId t o l order = runQuery c ( filterDocuments o l order
 204                                                 $ viewDocuments cId t ntId)
 205   where
 206     ntId = nodeTypeId NodeDocument
 207
 208 viewDocuments :: CorpusId -> Trash -> NodeTypeId -> Query FacetDocRead
 209 viewDocuments cId t ntId = proc () -> do
 210   n  <- queryNodeTable     -< ()
 211   nn <- queryNodeNodeTable -< ()
 212   restrict -< _node_id          n  .== nodeNode_node2_id nn
 213   restrict -< nodeNode_node1_id nn .== (pgInt4 cId)
 214   restrict -< _node_typename    n  .== (pgInt4 ntId)
 215   restrict -< nodeNode_delete   nn .== (pgBool t)
 216   returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nodeNode_favorite nn) (pgInt4 1)
 217
 218
 219 ------------------------------------------------------------------------
 220
 221 filterDocuments :: (PGOrd date, PGOrd title, PGOrd favorite) =>
 222      Maybe Gargantext.Core.Types.Offset
 223      -> Maybe Gargantext.Core.Types.Limit
 224      -> Maybe OrderBy
 225      -> Select (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
 226      -> Query  (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
 227 filterDocuments o l order q = limit' l $ offset' o $ orderBy ordering q
 228   where
 229     ordering = case order of
 230       (Just DateAsc)   -> asc  facetDoc_created
 231
 232       (Just TitleAsc)  -> asc  facetDoc_title
 233       (Just TitleDesc) -> desc facetDoc_title
 234
 235       (Just FavAsc)    -> asc  facetDoc_favorite
 236       (Just FavDesc)   -> desc facetDoc_favorite
 237       _                -> desc facetDoc_created
 238
 239 ------------------------------------------------------------------------
 240 -- | TODO move this queries utilties elsewhere
 241
 242 leftJoin3' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
 243 leftJoin3' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
 244     where
 245          cond12 = undefined
 246          cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
 247          cond23 = undefined
 248
 249
 250 leftJoin3 :: ( Default Unpackspec columnsL1 columnsL1
 251              , Default Unpackspec columnsL2 columnsL2
 252              , Default Unpackspec columnsL3 columnsL3
 253
 254              , Default Unpackspec nullableColumnsL2 nullableColumnsL2
 255
 256              , Default NullMaker  columnsL2  nullableColumnsL2
 257              , Default NullMaker (columnsL1, nullableColumnsL2) nullableColumnsL3
 258              )
 259              =>
 260               Query columnsL1 -> Query columnsL2 -> Query columnsL3
 261                 -> ((columnsL1, columnsL2) -> Column PGBool)
 262                 -> ((columnsL3, (columnsL1, nullableColumnsL2)) -> Column PGBool)
 263                 -> Query (columnsL3, nullableColumnsL3)
 264 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
 265
 266 --{-
 267 leftJoin4' :: Query (NodeRead, (NodeReadNull, (NgramsReadNull, NodeReadNull)))
 268 leftJoin4' = leftJoin4 queryNgramsTable queryNodeTable queryNodeTable queryNodeTable cond12 cond23 cond34
 269     where
 270          cond12 :: (NgramsRead, NodeRead) -> Column PGBool
 271          cond12 = undefined
 272
 273          cond23 :: (NodeRead, (NgramsRead, NodeReadNull)) -> Column PGBool
 274          cond23 = undefined
 275
 276          cond34 :: (NodeRead, (NodeRead, (NgramsReadNull, NodeReadNull))) -> Column PGBool
 277          cond34 = undefined
 278
 279 {-
 280 rightJoin4' :: Query (((NodeReadNull, NodeReadNull), NodeReadNull), NodeRead)
 281 rightJoin4' = rightJoin4 queryNodeTable queryNodeTable queryNodeTable queryNodeTable cond12 cond23 cond34
 282     where
 283          cond12 :: (NodeRead, NodeRead) -> Column PGBool
 284          cond12 = undefined
 285
 286          cond23 :: ((NodeReadNull, NodeRead), NodeRead) -> Column PGBool
 287          cond23 = undefined
 288
 289          cond34 :: (((NodeReadNull, NodeReadNull), NodeRead), NodeRead) -> Column PGBool
 290          cond34 = undefined
 291
 292 --}
 293
 294
 295 leftJoin4
 296   :: (Default Unpackspec fieldsL1 fieldsL1,
 297       Default Unpackspec fieldsL2 fieldsL2,
 298       Default Unpackspec nullableFieldsR1 nullableFieldsR1,
 299       Default Unpackspec fieldsL3 fieldsL3,
 300       Default Unpackspec nullableFieldsR2 nullableFieldsR2,
 301       Default Unpackspec fieldsR fieldsR,
 302       Default NullMaker fieldsR nullableFieldsR2,
 303       Default NullMaker (fieldsL2, nullableFieldsR1) nullableFieldsR3,
 304       Default NullMaker (fieldsL3, nullableFieldsR2) nullableFieldsR1) =>
 305      Opaleye.Select fieldsL3
 306      -> Opaleye.Select fieldsR
 307      -> Opaleye.Select fieldsL2
 308      -> Opaleye.Select fieldsL1
 309      -> ((fieldsL3, fieldsR) -> Column PGBool)
 310      -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
 311      -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
 312      -> Opaleye.Select (fieldsL1, nullableFieldsR3)
 313 leftJoin4 q1 q2 q3 q4 cond12 cond23 cond34 = leftJoin q4 (leftJoin q3 (leftJoin q1 q2 cond12) cond23) cond34
 314
 315
 316 -- rightJoin4 q1 q2 q3 q4 cond12 cond23 cond34 = rightJoin q4 (rightJoin q3 (rightJoin q1 q2 cond12) cond23) cond34
 317
 318
 319 leftJoin5' :: Query (NodeRead, (NodeReadNull, (NodeReadNull, (NodeReadNull, NodeReadNull))))
 320 leftJoin5' = leftJoin5 queryNodeTable queryNodeTable queryNodeTable queryNodeTable queryNodeTable cond12 cond23 cond34 cond45
 321     where
 322          cond12 :: (NodeRead, NodeRead) -> Column PGBool
 323          cond12 = undefined
 324
 325          cond23 :: (NodeRead, (NodeRead, NodeReadNull)) -> Column PGBool
 326          cond23 = undefined
 327
 328          cond34 :: (NodeRead, (NodeRead, (NodeReadNull, NodeReadNull))) -> Column PGBool
 329          cond34 = undefined
 330
 331          cond45 :: (NodeRead, (NodeRead, (NodeReadNull, (NodeReadNull, NodeReadNull)))) -> Column PGBool
 332          cond45 = undefined
 333
 334
 335 leftJoin5 :: ( Default Unpackspec fieldsL1 fieldsL1,
 336                Default Unpackspec fieldsL2 fieldsL2,
 337                Default Unpackspec nullableFieldsR1 nullableFieldsR1,
 338                Default Unpackspec fieldsL3 fieldsL3,
 339                Default Unpackspec nullableFieldsR2 nullableFieldsR2,
 340                Default Unpackspec fieldsL4 fieldsL4,
 341                Default Unpackspec nullableFieldsR3 nullableFieldsR3,
 342                Default Unpackspec fieldsR fieldsR,
 343                Default NullMaker fieldsR nullableFieldsR3,
 344                Default NullMaker (fieldsL2, nullableFieldsR1) nullableFieldsR4,
 345                Default NullMaker (fieldsL3, nullableFieldsR2) nullableFieldsR1,
 346                Default NullMaker (fieldsL4, nullableFieldsR3) nullableFieldsR2) =>
 347                Query fieldsR
 348                -> Query fieldsL4
 349                -> Query fieldsL3
 350                -> Query fieldsL2
 351                -> Query fieldsL1
 352                -> ((fieldsL4, fieldsR) -> Column PGBool)
 353                -> ((fieldsL3, (fieldsL4, nullableFieldsR3)) -> Column PGBool)
 354                -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
 355                -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
 356                -> Query (fieldsL1, nullableFieldsR4)
 357 leftJoin5 q1 q2 q3 q4 q5 cond12 cond23 cond34 cond45 = leftJoin q5 (leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34) cond45
 358
 359
 360 leftJoin6 :: ( Default Unpackspec fieldsL1 fieldsL1,
 361                Default Unpackspec fieldsL2 fieldsL2,
 362                Default Unpackspec nullableFieldsR1 nullableFieldsR1,
 363                Default Unpackspec fieldsL3 fieldsL3,
 364                Default Unpackspec nullableFieldsR2 nullableFieldsR2,
 365                Default Unpackspec fieldsL4 fieldsL4,
 366                Default Unpackspec nullableFieldsR3 nullableFieldsR3,
 367                Default Unpackspec fieldsL5 fieldsL5,
 368                Default Unpackspec nullableFieldsR4 nullableFieldsR4,
 369                Default Unpackspec fieldsR fieldsR,
 370                Default NullMaker fieldsR nullableFieldsR4,
 371                Default NullMaker (fieldsL2, nullableFieldsR1) nullableFieldsR5,
 372                Default NullMaker (fieldsL3, nullableFieldsR2) nullableFieldsR1,
 373                Default NullMaker (fieldsL4, nullableFieldsR3) nullableFieldsR2,
 374                Default NullMaker (fieldsL5, nullableFieldsR4) nullableFieldsR3) =>
 375      Query fieldsR
 376      -> Query fieldsL5
 377      -> Query fieldsL4
 378      -> Query fieldsL3
 379      -> Query fieldsL2
 380      -> Query fieldsL1 -> ((fieldsL5, fieldsR) -> Column PGBool)
 381      -> ((fieldsL4, (fieldsL5, nullableFieldsR4)) -> Column PGBool)
 382      -> ((fieldsL3, (fieldsL4, nullableFieldsR3)) -> Column PGBool)
 383      -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
 384      -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
 385      -> Query (fieldsL1, nullableFieldsR5)
 386 leftJoin6 q1 q2 q3 q4 q5 q6 cond12 cond23 cond34 cond45 cond56 =
 387   leftJoin q6 (leftJoin q5 (leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34) cond45) cond56
 388
 389