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