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.Ngrams
  48 import Gargantext.Database.Node
  49 import Gargantext.Database.NodeNgram
  50 import Gargantext.Database.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 ------------------------------------------------------------------------
 199
 200 runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd [FacetDoc]
 201 runViewDocuments cId t o l order = mkCmd $ \c -> runViewDocuments' c cId t o l order
 202
 203 -- | TODO use only Cmd with Reader and delete function below
 204 runViewDocuments' :: Connection -> CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
 205 runViewDocuments' c cId t o l order = runQuery c ( filterDocuments o l order
 206                                                 $ viewDocuments cId t ntId)
 207   where
 208     ntId = nodeTypeId NodeDocument
 209
 210 viewDocuments :: CorpusId -> Trash -> NodeTypeId -> Query FacetDocRead
 211 viewDocuments cId t ntId = proc () -> do
 212   n  <- queryNodeTable     -< ()
 213   nn <- queryNodeNodeTable -< ()
 214   restrict -< _node_id          n  .== nodeNode_node2_id nn
 215   restrict -< nodeNode_node1_id nn .== (pgInt4 cId)
 216   restrict -< _node_typename    n  .== (pgInt4 ntId)
 217   restrict -< nodeNode_delete   nn .== (pgBool t)
 218   returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nodeNode_favorite nn) (pgInt4 1)
 219
 220
 221 ------------------------------------------------------------------------
 222
 223 filterDocuments :: (PGOrd date, PGOrd title, PGOrd favorite) =>
 224      Maybe Gargantext.Core.Types.Offset
 225      -> Maybe Gargantext.Core.Types.Limit
 226      -> Maybe OrderBy
 227      -> Select (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
 228      -> Query  (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
 229 filterDocuments o l order q = limit' l $ offset' o $ orderBy ordering q
 230   where
 231     ordering = case order of
 232       (Just DateAsc)   -> asc  facetDoc_created
 233
 234       (Just TitleAsc)  -> asc  facetDoc_title
 235       (Just TitleDesc) -> desc facetDoc_title
 236
 237       (Just FavAsc)    -> asc  facetDoc_favorite
 238       (Just FavDesc)   -> desc facetDoc_favorite
 239       _                -> desc facetDoc_created
 240
 241
 242
 243
 244 ------------------------------------------------------------------------
 245 -- | TODO move this queries utilties elsewhere
 246
 247 leftJoin3' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
 248 leftJoin3' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
 249     where
 250          cond12 = undefined
 251          cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
 252          cond23 = undefined
 253
 254
 255 leftJoin3 :: ( Default Unpackspec columnsL1 columnsL1
 256              , Default Unpackspec columnsL2 columnsL2
 257              , Default Unpackspec columnsL3 columnsL3
 258
 259              , Default Unpackspec nullableColumnsL2 nullableColumnsL2
 260
 261              , Default NullMaker  columnsL2  nullableColumnsL2
 262              , Default NullMaker (columnsL1, nullableColumnsL2) nullableColumnsL3
 263              )
 264              =>
 265               Query columnsL1 -> Query columnsL2 -> Query columnsL3
 266                 -> ((columnsL1, columnsL2) -> Column PGBool)
 267                 -> ((columnsL3, (columnsL1, nullableColumnsL2)) -> Column PGBool)
 268                 -> Query (columnsL3, nullableColumnsL3)
 269 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
 270
 271 --{-
 272
 273 leftJoin4' :: Query (NodeRead, (NodeReadNull, (NodeReadNull, NodeReadNull)))
 274 leftJoin4' = leftJoin4 queryNodeTable queryNodeTable queryNodeTable queryNodeTable cond12 cond23 cond34
 275     where
 276          cond12 = undefined
 277
 278          cond23 :: (NodeRead, (NodeRead, NodeReadNull)) -> Column PGBool
 279          cond23 = undefined
 280
 281          cond34 :: (NodeRead, (NodeRead, (NodeReadNull, NodeReadNull))) -> Column PGBool
 282          cond34 = undefined
 283
 284
 285 leftJoin4 :: ( Default Unpackspec fieldsL1 fieldsL1,
 286                Default Unpackspec fieldsL2 fieldsL2,
 287                Default Unpackspec fieldsL3 fieldsL3,
 288                Default Unpackspec fieldsR fieldsR,
 289
 290                Default Unpackspec nullableFieldsL1 nullableFieldsL1,
 291                Default Unpackspec nullableFieldsL2 nullableFieldsL2,
 292                Default NullMaker fieldsR nullableFieldsL2,
 293                Default NullMaker (fieldsL2, nullableFieldsL1) nullableFieldsL3,
 294                Default NullMaker (fieldsL3, nullableFieldsL2) nullableFieldsL1) =>
 295      Query fieldsL3
 296      -> Query fieldsR
 297      -> Query fieldsL2
 298      -> Query fieldsL1
 299      -> ((fieldsL3, fieldsR)
 300          -> Column PGBool)
 301      -> ((fieldsL2, (fieldsL3, nullableFieldsL2))
 302          -> Column PGBool)
 303      -> ((fieldsL1, (fieldsL2, nullableFieldsL1))
 304          -> Column PGBool)
 305      -> Query (fieldsL1, nullableFieldsL3)
 306 leftJoin4 q1 q2 q3 q4 cond12 cond23 cond34 = leftJoin q4 (leftJoin q3 (leftJoin q1 q2 cond12) cond23) cond34
 307 --}
 308
 309 {-
 310 -}
 311 leftJoin5' :: Query (NodeRead, (NodeReadNull, (NodeReadNull, (NodeReadNull, NodeReadNull))))
 312 leftJoin5' = leftJoin5 queryNodeTable queryNodeTable queryNodeTable queryNodeTable queryNodeTable cond12 cond23 cond34 cond45
 313     where
 314          cond12 :: (NodeRead, NodeRead) -> Column PGBool
 315          cond12 = undefined
 316
 317          cond23 :: (NodeRead, (NodeRead, NodeReadNull)) -> Column PGBool
 318          cond23 = undefined
 319
 320          cond34 :: (NodeRead, (NodeRead, (NodeReadNull, NodeReadNull))) -> Column PGBool
 321          cond34 = undefined
 322
 323          cond45 :: (NodeRead, (NodeRead, (NodeReadNull, (NodeReadNull, NodeReadNull)))) -> Column PGBool
 324          cond45 = undefined
 325
 326
 327 leftJoin5 :: ( Default Unpackspec fieldsL1 fieldsL1,
 328                Default Unpackspec fieldsL2 fieldsL2,
 329                Default Unpackspec nullableFieldsR1 nullableFieldsR1,
 330                Default Unpackspec fieldsL3 fieldsL3,
 331                Default Unpackspec nullableFieldsR2 nullableFieldsR2,
 332                Default Unpackspec fieldsL4 fieldsL4,
 333                Default Unpackspec nullableFieldsR3 nullableFieldsR3,
 334                Default Unpackspec fieldsR fieldsR,
 335                Default NullMaker fieldsR nullableFieldsR3,
 336                Default NullMaker (fieldsL2, nullableFieldsR1) nullableFieldsR4,
 337                Default NullMaker (fieldsL3, nullableFieldsR2) nullableFieldsR1,
 338                Default NullMaker (fieldsL4, nullableFieldsR3) nullableFieldsR2) =>
 339                Query fieldsR
 340                -> Query fieldsL4
 341                -> Query fieldsL3
 342                -> Query fieldsL2
 343                -> Query fieldsL1
 344                -> ((fieldsL4, fieldsR) -> Column PGBool)
 345                -> ((fieldsL3, (fieldsL4, nullableFieldsR3)) -> Column PGBool)
 346                -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
 347                -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
 348                -> Query (fieldsL1, nullableFieldsR4)
 349 leftJoin5 q1 q2 q3 q4 q5 cond12 cond23 cond34 cond45 = leftJoin q5 (leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34) cond45
 350
 351
 352 leftJoin6 :: ( Default Unpackspec fieldsL1 fieldsL1,
 353                Default Unpackspec fieldsL2 fieldsL2,
 354                Default Unpackspec nullableFieldsR1 nullableFieldsR1,
 355                Default Unpackspec fieldsL3 fieldsL3,
 356                Default Unpackspec nullableFieldsR2 nullableFieldsR2,
 357                Default Unpackspec fieldsL4 fieldsL4,
 358                Default Unpackspec nullableFieldsR3 nullableFieldsR3,
 359                Default Unpackspec fieldsL5 fieldsL5,
 360                Default Unpackspec nullableFieldsR4 nullableFieldsR4,
 361                Default Unpackspec fieldsR fieldsR,
 362                Default NullMaker fieldsR nullableFieldsR4,
 363                Default NullMaker (fieldsL2, nullableFieldsR1) nullableFieldsR5,
 364                Default NullMaker (fieldsL3, nullableFieldsR2) nullableFieldsR1,
 365                Default NullMaker (fieldsL4, nullableFieldsR3) nullableFieldsR2,
 366                Default NullMaker (fieldsL5, nullableFieldsR4) nullableFieldsR3) =>
 367      Query fieldsR
 368      -> Query fieldsL5
 369      -> Query fieldsL4
 370      -> Query fieldsL3
 371      -> Query fieldsL2
 372      -> Query fieldsL1 -> ((fieldsL5, fieldsR) -> Column PGBool)
 373      -> ((fieldsL4, (fieldsL5, nullableFieldsR4)) -> Column PGBool)
 374      -> ((fieldsL3, (fieldsL4, nullableFieldsR3)) -> Column PGBool)
 375      -> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
 376      -> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
 377      -> Query (fieldsL1, nullableFieldsR5)
 378 leftJoin6 q1 q2 q3 q4 q5 q6 cond12 cond23 cond34 cond45 cond56 =
 379   leftJoin q6 (leftJoin q5 (leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34) cond45) cond56
 380
 381