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 NoImplicitPrelude         #-}
  21 {-# LANGUAGE NoMonomorphismRestriction #-}
  22 {-# LANGUAGE TemplateHaskell           #-}
  23
  24 ------------------------------------------------------------------------
  25 module Gargantext.Database.Facet
  26   where
  27 ------------------------------------------------------------------------
  28
  29 import Prelude hiding (null, id, map, sum, not)
  30 import GHC.Generics (Generic)
  31
  32 -- import Data.Aeson (Value)
  33 import Control.Arrow (returnA)
  34 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  35
  36 import Data.Aeson.TH (deriveJSON)
  37 import Data.Maybe (Maybe)
  38 import Data.Profunctor.Product.Default (Default)
  39 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  40 import Data.Time (UTCTime)
  41 import Data.Time.Segment (jour)
  42 import Data.Swagger
  43
  44 import           Database.PostgreSQL.Simple (Connection)
  45 import           Opaleye
  46 import           Opaleye.Internal.Join (NullMaker)
  47 import qualified Opaleye.Internal.Unpackspec()
  48
  49 import Test.QuickCheck.Arbitrary
  50 import Test.QuickCheck (elements)
  51
  52 import Gargantext.Core.Types
  53 import Gargantext.Database.Types.Node (NodeType)
  54 import Gargantext.Core.Utils.Prefix (unPrefix)
  55 import Gargantext.Database.NodeNode
  56 import Gargantext.Database.NodeNodeNgram
  57 import Gargantext.Database.Node
  58 import Gargantext.Database.Queries
  59 import Gargantext.Database.Config (nodeTypeId)
  60 -- import Gargantext.Database.NodeNgram
  61
  62 ------------------------------------------------------------------------
  63 -- | DocFacet
  64
  65 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
  66 --    deriving (Show, Generic)
  67 --instance FromJSON Facet
  68 --instance ToJSON   Facet
  69
  70 type Favorite = Bool
  71
  72 type FacetDoc = Facet NodeId UTCTime HyperdataDocument Favorite Int
  73 type FacetSources = FacetDoc
  74 type FacetAuthors = FacetDoc
  75 type FacetTerms   = FacetDoc
  76
  77
  78
  79 data Facet id created hyperdata favorite ngramCount =
  80      FacetDoc { facetDoc_id         :: id
  81                , facetDoc_created    :: created
  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) hp fav ngramCount
  98                          | id'  <- [1..10]
  99                          , year <- [1990..2000]
 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 PGJsonb      )
 113                           (Column PGBool)
 114                           (Column PGInt4       )
 115
 116 -----------------------------------------------------------------------
 117
 118 data FacetChart = FacetChart { facetChart_time  :: UTCTime'
 119                              , facetChart_count :: Double
 120                         }
 121         deriving (Show, Generic)
 122 $(deriveJSON (unPrefix "facetChart_") ''FacetChart)
 123 instance ToSchema FacetChart
 124
 125 instance Arbitrary FacetChart where
 126     arbitrary = FacetChart <$> arbitrary <*> arbitrary
 127
 128 -----------------------------------------------------------------------
 129
 130 data OrderBy =  DateAsc | DateDesc
 131        --      | TitleAsc | TitleDesc
 132              | FavDesc  | FavAsc -- | NgramCount
 133
 134 viewDocuments :: CorpusId -> NodeTypeId -> Query FacetDocRead
 135 viewDocuments cId ntId = proc () -> do
 136   n  <- queryNodeTable -< ()
 137   nn <- queryNodeNodeTable -< ()
 138   restrict -< _node_id n .== nodeNode_node2_id nn
 139   restrict -< nodeNode_node1_id nn .== (pgInt4 cId)
 140   restrict -< _node_typename n     .== (pgInt4 ntId)
 141   returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_hyperdata n) (nodeNode_favorite nn) (pgInt4 1)
 142
 143
 144 filterDocuments :: (PGOrd date, PGOrd favorite) =>
 145      Maybe Gargantext.Core.Types.Offset
 146      -> Maybe Gargantext.Core.Types.Limit
 147      -> OrderBy
 148      -> Select (Facet id (Column date) hyperdata (Column favorite) ngramCount)
 149      -> Query  (Facet id (Column date) hyperdata (Column favorite) ngramCount)
 150 filterDocuments o l order q = limit' l $ offset' o $ orderBy ordering q
 151   where
 152     ordering = case order of
 153       DateAsc   -> asc  facetDoc_created
 154       DateDesc  -> desc facetDoc_created
 155
 156       --TitleAsc  -> asc  facetDoc_hyperdata
 157       --TitleDesc -> desc facetDoc_hyperdata
 158
 159       FavAsc    -> asc  facetDoc_favorite
 160       FavDesc   -> desc facetDoc_favorite
 161
 162
 163 runViewDocuments :: CorpusId -> Maybe Offset -> Maybe Limit -> OrderBy -> Cmd [FacetDoc]
 164 runViewDocuments cId o l order = mkCmd $ \c -> runQuery c ( filterDocuments o l order
 165                                                 $ viewDocuments cId ntId)
 166   where
 167     ntId = nodeTypeId NodeDocument
 168
 169
 170 {-
 171 getDocFacet :: Connection -> NodeType -> Int -> Maybe NodeType
 172             -> Maybe Offset -> Maybe Limit
 173             -> IO [FacetDoc]
 174 getDocFacet conn parentType parentId nodeType maybeOffset maybeLimit =
 175     runQuery conn $ selectDocFacet parentType parentId nodeType maybeOffset maybeLimit
 176
 177 selectDocFacet :: NodeType -> ParentId -> Maybe NodeType
 178                -> Maybe Offset -> Maybe Limit
 179                -> Query FacetDocRead
 180 selectDocFacet pType parentId maybeNodeType maybeOffset maybeLimit =
 181         limit' maybeLimit $ offset' maybeOffset
 182                           $ orderBy (asc facetDoc_created)
 183                           $ selectDocFacet' pType parentId maybeNodeType
 184
 185
 186 -- | Left join to the favorites
 187 nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
 188 nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
 189     where
 190         eqNode (Node n1 _ _ _ _ _ _, NodeNode _ n2 _ _ _ ) = ((.==) n1 n2)
 191
 192
 193 nodeNodeLeftJoin' :: (Column (Nullable PGInt4))
 194                   -> Query (NodeRead, NodeNodeReadNull)
 195 nodeNodeLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeTable (eqNode nId)
 196         where
 197             eqNode n (Node n1 _ _ _ _ _ _, NodeNode n1' n2 _ _ _)
 198                    = foldl (.&&) (pgBool True) [ ((.==) n1 n2)
 199                                                , ((.==) n1' n)
 200                                                ]
 201
 202 nodeNodeLeftJoin'' :: Query (NodeRead, NodeRead, NodeNodeRead)
 203 nodeNodeLeftJoin'' = join3 queryNodeTable queryNodeTable queryNodeNodeTable eqNode
 204         where
 205             eqNode (Node n1 _ _ _ _ _ _, Node n2 _ _ _ _ _ _, NodeNode n1' n2' _ _ _)
 206                    = foldl (.&&) (pgBool True) [ ((.==) n2 n2')
 207                                                , ((.==) (toNullable n1) n1')
 208                                                ]
 209
 210 -- | Left join to the ngram count per document
 211 nodeNodeNgramLeftJoin :: Query (NodeRead, NodeNodeNgramReadNull)
 212 nodeNodeNgramLeftJoin = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode)
 213      where
 214         eqNode (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' _ _ _) = ((.==) n1 n1')
 215
 216
 217 nodeNodeNgramLeftJoin' :: Column (Nullable PGInt4)
 218                        -> Query (NodeRead, NodeNodeNgramReadNull)
 219 nodeNodeNgramLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode nId)
 220      where
 221         eqNode nId' (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' n2 _ _)
 222                  = (.&&) ((.==) n1 n1')
 223                          ((.==) nId' (toNullable n2))
 224
 225
 226 leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
 227               Default NullMaker columnsR nullableColumnsR,
 228               Default Unpackspec columnsR columnsR,
 229               Default Unpackspec nullableColumnsR nullableColumnsR,
 230               Default Unpackspec columnsL1 columnsL1,
 231               Default Unpackspec columnsL columnsL) =>
 232               Query columnsL1 -> Query columnsR -> Query columnsL
 233                 -> ((columnsL1, columnsR) -> Column PGBool)
 234                 -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
 235                 -> Query (columnsL, nullableColumnsR1)
 236 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
 237
 238
 239 leftJoin3' :: Query (NodeRead, (NodeReadNull, NodeNodeNgramReadNull))
 240 leftJoin3' = leftJoin3 queryNodeTable  queryNodeNodeNgramTable queryNodeTable cond12 cond23
 241     where
 242          cond12 (Node occId _ _ _ _ _ _, NodeNodeNgram occId' _ _ _)
 243                 = (.==) occId occId'
 244
 245          cond23 :: (NodeRead, (NodeRead, NodeNodeNgramReadNull)) -> Column PGBool
 246          cond23 (Node  docId _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ docId' _ _))
 247                 = (.||) ((.==) (toNullable docId) docId') (isNull docId')
 248
 249
 250 leftJoin3''' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
 251 leftJoin3''' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
 252     where
 253          cond12 (NodeNode favId _ _ _ _, Node favId' _ _ _ _ _ _)
 254                 = (.||) ((.==) favId (toNullable favId')) (isNull $ toNullable favId)
 255
 256          cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
 257          cond23 (Node  nId _ _ _ _ _ _, (NodeNode _ nId' _ _ _, Node _ _ _ _ _ _ _ ))
 258                 = ((.==) (nId) (nId'))
 259
 260
 261 -- | Building the facet
 262 selectDocFacet' :: NodeType -> ParentId -> Maybe NodeType -> Query FacetDocRead
 263 selectDocFacet' _ pId _ = proc () -> do
 264         (n1,(nn,_n2)) <- leftJoin3''' -< ()
 265         restrict -< (.&&) (_node_parentId n1 .== (toNullable $ pgInt4 pId))
 266                           (_node_typename n1 .== (pgInt4 $ nodeTypeId NodeDocument))
 267
 268 --        restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 $ nodeTypeId Favorites))
 269 --                          (isNull $ node_typename n2)
 270 --
 271 --        restrict -< (.||) (node_parentId n2 .== (toNullable $ pgInt4 $ nodeTypeId Favorites))
 272 --                          (isNull $ node_parentId n2)
 273
 274         let isFav = ifThenElse (isNull $ nodeNode_score nn) (pgBool False) (pgBool True)
 275
 276         returnA  -< FacetDoc (_node_id n1) (_node_date n1) (_node_hyperdata n1) (isFav) (pgInt4 1)
 277
 278 -}