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