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 Prelude hiding (null, id, map, sum, not, read)
  31 import Prelude (Enum, Bounded, minBound, maxBound)
  32 import GHC.Generics (Generic)
  33
  34 import Data.Aeson (FromJSON, ToJSON)
  35 import Data.Either(Either(Left))
  36 import Data.Profunctor.Product.Default
  37 import Control.Arrow (returnA)
  38 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  39
  40 import Data.Aeson.TH (deriveJSON)
  41 import Data.Maybe (Maybe)
  42 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  43 import Data.Text (Text)
  44 import Data.Time (UTCTime)
  45 import Data.Time.Segment (jour)
  46 import Data.Swagger
  47
  48 import qualified Database.PostgreSQL.Simple as DPS
  49 import Database.PostgreSQL.Simple (Connection)
  50 import           Opaleye
  51 import Opaleye.Join
  52 import Opaleye.Internal.Join (NullMaker)
  53 import qualified Opaleye.Internal.Unpackspec()
  54 import Database.PostgreSQL.Simple.SqlQQ (sql)
  55
  56 import Servant.API
  57 import Test.QuickCheck.Arbitrary
  58 import Test.QuickCheck (elements)
  59
  60 import Gargantext.Core.Types
  61 import Gargantext.Core.Utils.Prefix (unPrefix)
  62 import Gargantext.Database.NodeNode
  63 import Gargantext.Database.Node
  64 import Gargantext.Database.Ngrams
  65 import Gargantext.Database.NodeNgram
  66 import Gargantext.Database.Queries
  67 import Gargantext.Database.Config (nodeTypeId)
  68 -- import Gargantext.Database.NodeNgram
  69
  70 ------------------------------------------------------------------------
  71 -- | DocFacet
  72
  73 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
  74 --    deriving (Show, Generic)
  75 --instance FromJSON Facet
  76 --instance ToJSON   Facet
  77
  78 type Favorite = Bool
  79 type Title    = Text
  80
  81 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument Favorite Int
  82 type FacetSources = FacetDoc
  83 type FacetAuthors = FacetDoc
  84 type FacetTerms   = FacetDoc
  85
  86
  87
  88 data Facet id created title hyperdata favorite ngramCount =
  89      FacetDoc { facetDoc_id         :: id
  90               , facetDoc_created    :: created
  91               , facetDoc_title      :: title
  92               , facetDoc_hyperdata  :: hyperdata
  93               , facetDoc_favorite   :: favorite
  94               , facetDoc_ngramCount :: ngramCount
  95               } deriving (Show, Generic)
  96
  97 -- | JSON instance
  98
  99 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
 100
 101 -- | Documentation instance
 102 instance ToSchema FacetDoc
 103
 104 -- | Mock and Quickcheck instances
 105
 106 instance Arbitrary FacetDoc where
 107     arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp fav ngramCount
 108                          | id'  <- [1..10]
 109                          , year <- [1990..2000]
 110                          , t    <- ["title", "another title"]
 111                          , hp   <- hyperdataDocuments
 112                          , fav  <- [True, False]
 113                          , ngramCount <- [3..100]
 114                          ]
 115
 116 -- Facets / Views for the Front End
 117 -- | Database instances
 118 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
 119 $(makeLensesWith abbreviatedFields   ''Facet)
 120
 121 type FacetDocRead = Facet (Column PGInt4       )
 122                           (Column PGTimestamptz)
 123                           (Column PGText       )
 124                           (Column PGJsonb      )
 125                           (Column PGBool)
 126                           (Column PGInt4       )
 127
 128 -----------------------------------------------------------------------
 129
 130 data FacetChart = FacetChart { facetChart_time  :: UTCTime'
 131                              , facetChart_count :: Double
 132                         }
 133         deriving (Show, Generic)
 134 $(deriveJSON (unPrefix "facetChart_") ''FacetChart)
 135 instance ToSchema FacetChart
 136
 137 instance Arbitrary FacetChart where
 138     arbitrary = FacetChart <$> arbitrary <*> arbitrary
 139
 140 -----------------------------------------------------------------------
 141 type Trash   = Bool
 142 data OrderBy =  DateAsc | DateDesc
 143              | TitleAsc | TitleDesc
 144              | FavDesc  | FavAsc
 145              deriving (Generic, Enum, Bounded, Read, Show)
 146              -- | NgramCoun
 147
 148 instance FromHttpApiData OrderBy
 149   where
 150     parseUrlPiece "DateAsc"  = pure DateAsc
 151     parseUrlPiece "DateDesc" = pure DateDesc
 152     parseUrlPiece "TitleAsc" = pure TitleAsc
 153     parseUrlPiece "TitleDesc" = pure TitleDesc
 154     parseUrlPiece "FavAsc"   = pure FavAsc
 155     parseUrlPiece "FavDesc"   = pure FavDesc
 156     parseUrlPiece _           = Left "Unexpected value of OrderBy"
 157
 158 instance ToParamSchema OrderBy
 159 instance FromJSON  OrderBy
 160 instance ToJSON    OrderBy
 161 instance ToSchema  OrderBy
 162 instance Arbitrary OrderBy
 163   where
 164     arbitrary = elements [minBound..maxBound]
 165
 166
 167 runViewAuthorsDoc :: Connection -> ContactId -> Trash -> NodeType -> IO [FacetDoc]
 168 runViewAuthorsDoc c cId t nt = runQuery c (viewAuthorsDoc cId t nt)
 169
 170 -- TODO add delete ?
 171 viewAuthorsDoc :: ContactId -> Trash -> NodeType -> Query FacetDocRead
 172 viewAuthorsDoc cId t nt = proc () -> do
 173   (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc      -< ()
 174
 175   {-nn         <- queryNodeNodeTable -< ()
 176   restrict -< nodeNode_node1_id nn .== _node_id doc
 177   -- restrict -< nodeNode_delete   nn .== (pgBool t)
 178   -}
 179
 180   restrict -< _node_id   contact   .== (toNullable $ pgInt4 cId)
 181   restrict -< _node_typename doc   .== (pgInt4 $ nodeTypeId nt)
 182
 183   returnA  -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
 184
 185 queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
 186 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
 187     where
 188          cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
 189          cond12 (nodeNgram, doc) =  _node_id                  doc
 190                                 .== nodeNgram_NodeNgramNodeId nodeNgram
 191
 192          cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
 193          cond23 (ngrams, (nodeNgram, _)) =  ngrams_id                  ngrams
 194                                         .== nodeNgram_NodeNgramNgramId nodeNgram
 195
 196          cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
 197          cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams     .== nodeNgram_NodeNgramNgramId        nodeNgram2
 198
 199          cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
 200          cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== nodeNgram_NodeNgramNodeId         nodeNgram2
 201
 202
 203
 204
 205
 206 viewDocuments :: CorpusId -> Trash -> NodeTypeId -> Query FacetDocRead
 207 viewDocuments cId t ntId = proc () -> do
 208   n  <- queryNodeTable     -< ()
 209   nn <- queryNodeNodeTable -< ()
 210   restrict -< _node_id          n  .== nodeNode_node2_id nn
 211   restrict -< nodeNode_node1_id nn .== (pgInt4 cId)
 212   restrict -< _node_typename    n  .== (pgInt4 ntId)
 213   restrict -< nodeNode_delete   nn .== (pgBool t)
 214   returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nodeNode_favorite nn) (pgInt4 1)
 215
 216
 217 filterDocuments :: (PGOrd date, PGOrd title, PGOrd favorite) =>
 218      Maybe Gargantext.Core.Types.Offset
 219      -> Maybe Gargantext.Core.Types.Limit
 220      -> Maybe OrderBy
 221      -> Select (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
 222      -> Query  (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
 223 filterDocuments o l order q = limit' l $ offset' o $ orderBy ordering q
 224   where
 225     ordering = case order of
 226       (Just DateAsc)   -> asc  facetDoc_created
 227
 228       (Just TitleAsc)  -> asc  facetDoc_title
 229       (Just TitleDesc) -> desc facetDoc_title
 230
 231       (Just FavAsc)    -> asc  facetDoc_favorite
 232       (Just FavDesc)   -> desc facetDoc_favorite
 233       _                -> desc facetDoc_created
 234
 235
 236 runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd [FacetDoc]
 237 runViewDocuments cId t o l order = mkCmd $ \c -> runViewDocuments' c cId t o l order
 238
 239 -- | TODO use only Cmd with Reader and delete function below
 240 runViewDocuments' :: Connection -> CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
 241 runViewDocuments' c cId t o l order = runQuery c ( filterDocuments o l order
 242                                                 $ viewDocuments cId t ntId)
 243   where
 244     ntId = nodeTypeId NodeDocument
 245
 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