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.TH (makeAdaptorAndInstance)
  37 import Data.Swagger
  38 import Data.Text (Text)
  39 import Data.Time (UTCTime)
  40 import Data.Time.Segment (jour)
  41 import Database.PostgreSQL.Simple (Connection)
  42 import GHC.Generics (Generic)
  43 import Gargantext.Core.Types
  44 import Gargantext.Core.Utils.Prefix (unPrefix)
  45 import Gargantext.Database.Config (nodeTypeId)
  46 import Gargantext.Database.Schema.Ngrams
  47 import Gargantext.Database.Schema.Node
  48 import Gargantext.Database.Schema.NodeNgram
  49 import Gargantext.Database.Schema.NodeNode
  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
  77 data Facet id created title hyperdata favorite ngramCount =
  78      FacetDoc { facetDoc_id         :: id
  79               , facetDoc_created    :: created
  80               , facetDoc_title      :: title
  81               , facetDoc_hyperdata  :: hyperdata
  82               , facetDoc_favorite   :: favorite
  83               , facetDoc_ngramCount :: ngramCount
  84               } deriving (Show, Generic)
  85
  86 -- | JSON instance
  87
  88 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
  89
  90 -- | Documentation instance
  91 instance ToSchema FacetDoc
  92
  93 -- | Mock and Quickcheck instances
  94
  95 instance Arbitrary FacetDoc where
  96     arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp fav ngramCount
  97                          | id'  <- [1..10]
  98                          , year <- [1990..2000]
  99                          , t    <- ["title", "another title"]
 100                          , hp   <- hyperdataDocuments
 101                          , fav  <- [True, False]
 102                          , ngramCount <- [3..100]
 103                          ]
 104
 105 -- Facets / Views for the Front End
 106 -- | Database instances
 107 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
 108 $(makeLensesWith abbreviatedFields   ''Facet)
 109
 110 type FacetDocRead = Facet (Column PGInt4       )
 111                           (Column PGTimestamptz)
 112                           (Column PGText       )
 113                           (Column PGJsonb      )
 114                           (Column PGBool)
 115                           (Column PGInt4       )
 116
 117 -----------------------------------------------------------------------
 118
 119 data FacetChart = FacetChart { facetChart_time  :: UTCTime'
 120                              , facetChart_count :: Double
 121                         }
 122         deriving (Show, Generic)
 123 $(deriveJSON (unPrefix "facetChart_") ''FacetChart)
 124 instance ToSchema FacetChart
 125
 126 instance Arbitrary FacetChart where
 127     arbitrary = FacetChart <$> arbitrary <*> arbitrary
 128
 129 -----------------------------------------------------------------------
 130 type Trash   = Bool
 131 data OrderBy =  DateAsc | DateDesc
 132              | TitleAsc | TitleDesc
 133              | FavDesc  | FavAsc
 134              deriving (Generic, Enum, Bounded, Read, Show)
 135              -- | NgramCoun
 136
 137 instance FromHttpApiData OrderBy
 138   where
 139     parseUrlPiece "DateAsc"  = pure DateAsc
 140     parseUrlPiece "DateDesc" = pure DateDesc
 141     parseUrlPiece "TitleAsc" = pure TitleAsc
 142     parseUrlPiece "TitleDesc" = pure TitleDesc
 143     parseUrlPiece "FavAsc"   = pure FavAsc
 144     parseUrlPiece "FavDesc"   = pure FavDesc
 145     parseUrlPiece _           = Left "Unexpected value of OrderBy"
 146
 147 instance ToParamSchema OrderBy
 148 instance FromJSON  OrderBy
 149 instance ToJSON    OrderBy
 150 instance ToSchema  OrderBy
 151 instance Arbitrary OrderBy
 152   where
 153     arbitrary = elements [minBound..maxBound]
 154
 155
 156 runViewAuthorsDoc :: Connection -> ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
 157 runViewAuthorsDoc c cId t o l order = runQuery c (filterDocuments o l order $ viewAuthorsDoc cId t ntId)
 158   where
 159     ntId = NodeDocument
 160
 161 -- TODO add delete ?
 162 viewAuthorsDoc :: ContactId -> Trash -> NodeType -> Query FacetDocRead
 163 viewAuthorsDoc cId _ nt = proc () -> do
 164   (doc,(_,(_,(_,contact)))) <- queryAuthorsDoc      -< ()
 165
 166   {-nn         <- queryNodeNodeTable -< ()
 167   restrict -< nodeNode_node1_id nn .== _node_id doc
 168   -- restrict -< nodeNode_delete   nn .== (pgBool t)
 169   -}
 170
 171   restrict -< _node_id   contact   .== (toNullable $ pgInt4 cId)
 172   restrict -< _node_typename doc   .== (pgInt4 $ nodeTypeId nt)
 173
 174   returnA  -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
 175
 176 queryAuthorsDoc :: Query (NodeRead, (NodeNgramReadNull, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull))))
 177 queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable queryNodeNgramTable queryNodeTable cond12 cond23 cond34 cond45
 178     where
 179          cond12 :: (NodeNgramRead, NodeRead) -> Column PGBool
 180          cond12 (nodeNgram, doc) =  _node_id                  doc
 181                                 .== nodeNgram_NodeNgramNodeId nodeNgram
 182
 183          cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
 184          cond23 (ngrams, (nodeNgram, _)) =  ngrams_id                  ngrams
 185                                         .== nodeNgram_NodeNgramNgramId nodeNgram
 186
 187          cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
 188          cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams     .== nodeNgram_NodeNgramNgramId        nodeNgram2
 189
 190          cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
 191          cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id  contact    .== nodeNgram_NodeNgramNodeId         nodeNgram2
 192
 193
 194 ------------------------------------------------------------------------
 195
 196 runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd [FacetDoc]
 197 runViewDocuments cId t o l order = mkCmd $ \c -> runViewDocuments' c cId t o l order
 198
 199 -- | TODO use only Cmd with Reader and delete function below
 200 runViewDocuments' :: Connection -> CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
 201 runViewDocuments' c cId t o l order = runQuery c ( filterDocuments o l order
 202                                                 $ viewDocuments cId t ntId)
 203   where
 204     ntId = nodeTypeId NodeDocument
 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 ------------------------------------------------------------------------
 218
 219 filterDocuments :: (PGOrd date, PGOrd title, PGOrd favorite) =>
 220      Maybe Gargantext.Core.Types.Offset
 221      -> Maybe Gargantext.Core.Types.Limit
 222      -> Maybe OrderBy
 223      -> Select (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
 224      -> Query  (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
 225 filterDocuments o l order q = limit' l $ offset' o $ orderBy ordering q
 226   where
 227     ordering = case order of
 228       (Just DateAsc)   -> asc  facetDoc_created
 229
 230       (Just TitleAsc)  -> asc  facetDoc_title
 231       (Just TitleDesc) -> desc facetDoc_title
 232
 233       (Just FavAsc)    -> asc  facetDoc_favorite
 234       (Just FavDesc)   -> desc facetDoc_favorite
 235       _                -> desc facetDoc_created
 236