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 TemplateHaskell             #-}
  17 {-# LANGUAGE FlexibleContexts            #-}
  18 {-# LANGUAGE FlexibleInstances           #-}
  19 {-# LANGUAGE MultiParamTypeClasses       #-}
  20 {-# LANGUAGE FunctionalDependencies      #-}
  21 {-# LANGUAGE NoMonomorphismRestriction   #-}
  22
  23 ------------------------------------------------------------------------
  24 module Gargantext.Database.Facet
  25   where
  26 ------------------------------------------------------------------------
  27
  28 import Prelude hiding (null, id, map, sum, not)
  29 import GHC.Generics (Generic)
  30
  31 -- import Data.Aeson (Value)
  32 import Control.Arrow (returnA)
  33 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  34
  35 import Data.Aeson.TH (deriveJSON)
  36 import Data.Maybe (Maybe)
  37 import Data.Profunctor.Product.Default (Default)
  38 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  39 import Data.Time (UTCTime)
  40 import Data.Time.Segment (jour)
  41 import Data.Swagger
  42
  43 import           Database.PostgreSQL.Simple (Connection)
  44 import           Opaleye
  45 import           Opaleye.Internal.Join (NullMaker)
  46 import qualified Opaleye.Internal.Unpackspec()
  47
  48 import Test.QuickCheck.Arbitrary
  49 import Test.QuickCheck (elements)
  50
  51 import Gargantext.Types
  52 import Gargantext.Types.Node (NodeType)
  53 import Gargantext.Database.NodeNode
  54 import Gargantext.Database.NodeNodeNgram
  55 import Gargantext.Database.Node
  56 import Gargantext.Database.Queries
  57 import Gargantext.Utils.Prefix (unPrefix)
  58 -- import Gargantext.Database.NodeNgram
  59
  60 ------------------------------------------------------------------------
  61 -- | DocFacet
  62 type FacetDoc = Facet NodeId UTCTime HyperdataDocument Bool Int
  63
  64 data Facet id created hyperdata favorite ngramCount =
  65      FacetDoc { facetDoc_id         :: id
  66                , facetDoc_created    :: created
  67                , facetDoc_hyperdata  :: hyperdata
  68                , facetDoc_favorite   :: favorite
  69                , facetDoc_ngramCount :: ngramCount
  70                } deriving (Show, Generic)
  71
  72 -- | JSON instance
  73
  74 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
  75
  76 -- | Documentation instance
  77 instance ToSchema FacetDoc
  78
  79 -- | Mock and Quickcheck instances
  80
  81 instance Arbitrary FacetDoc where
  82     arbitrary = elements [ FacetDoc id' (jour year 01 01) hp fav ngramCount
  83                          | id'  <- [1..10]
  84                          , year <- [1990..2000]
  85                          , hp   <- hyperdataDocuments
  86                          , fav  <- [True, False]
  87                          , ngramCount <- [3..100]
  88                          ]
  89
  90 -- Facets / Views for the Front End
  91 -- | Database instances
  92 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
  93 $(makeLensesWith abbreviatedFields   ''Facet)
  94
  95 type FacetDocRead = Facet (Column PGInt4       )
  96                           (Column PGTimestamptz)
  97                           (Column PGJsonb      )
  98                           (Column PGBool       )
  99                           (Column PGInt4       )
 100
 101 ------------------------------------------------------------------------
 102
 103
 104 getDocFacet :: Connection -> Int -> Maybe NodeType
 105             -> Maybe Offset -> Maybe Limit
 106             -> IO [FacetDoc]
 107 getDocFacet conn parentId nodeType maybeOffset maybeLimit =
 108     runQuery conn $ selectDocFacet parentId nodeType maybeOffset maybeLimit
 109
 110 selectDocFacet :: ParentId -> Maybe NodeType
 111                -> Maybe Offset -> Maybe Limit
 112                -> Query FacetDocRead
 113 selectDocFacet parentId maybeNodeType maybeOffset maybeLimit =
 114         limit' maybeLimit $ offset' maybeOffset
 115                           $ orderBy (asc facetDoc_created)
 116                           $ selectDocFacet' parentId maybeNodeType
 117
 118
 119 -- | Left join to the favorites
 120 nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
 121 nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
 122     where
 123         eqNode (Node n1 _ _ _ _ _ _, NodeNode _ n2 _) = ((.==) n1 n2)
 124
 125
 126 nodeNodeLeftJoin' :: (Column (Nullable PGInt4))
 127                   -> Query (NodeRead, NodeNodeReadNull)
 128 nodeNodeLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeTable (eqNode nId)
 129         where
 130             eqNode n (Node n1 _ _ _ _ _ _, NodeNode n1' n2 _)
 131                    = foldl (.&&) (pgBool True) [ ((.==) n1 n2)
 132                                                , ((.==) n1' n)
 133                                                ]
 134
 135 nodeNodeLeftJoin'' :: Query (NodeRead, NodeRead, NodeNodeRead)
 136 nodeNodeLeftJoin'' = join3 queryNodeTable queryNodeTable queryNodeNodeTable eqNode
 137         where
 138             eqNode (Node n1 _ _ _ _ _ _, Node n2 _ _ _ _ _ _, NodeNode n1' n2' _)
 139                    = foldl (.&&) (pgBool True) [ ((.==) n2 n2')
 140                                                , ((.==) (toNullable n1) n1')
 141                                                ]
 142
 143 -- | Left join to the ngram count per document
 144 nodeNodeNgramLeftJoin :: Query (NodeRead, NodeNodeNgramReadNull)
 145 nodeNodeNgramLeftJoin = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode)
 146      where
 147         eqNode (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' _ _ _) = ((.==) n1 n1')
 148
 149
 150 nodeNodeNgramLeftJoin' :: Column (Nullable PGInt4)
 151                        -> Query (NodeRead, NodeNodeNgramReadNull)
 152 nodeNodeNgramLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode nId)
 153      where
 154         eqNode nId' (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' n2 _ _)
 155                  = (.&&) ((.==) n1 n1')
 156                          ((.==) nId' (toNullable n2))
 157
 158
 159 leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
 160               Default NullMaker columnsR nullableColumnsR,
 161               Default Unpackspec columnsR columnsR,
 162               Default Unpackspec nullableColumnsR nullableColumnsR,
 163               Default Unpackspec columnsL1 columnsL1,
 164               Default Unpackspec columnsL columnsL) =>
 165               Query columnsL1 -> Query columnsR -> Query columnsL
 166                 -> ((columnsL1, columnsR) -> Column PGBool)
 167                 -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
 168                 -> Query (columnsL, nullableColumnsR1)
 169 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
 170
 171
 172 leftJoin3' :: Query (NodeRead, (NodeReadNull, NodeNodeNgramReadNull))
 173 leftJoin3' = leftJoin3 queryNodeTable  queryNodeNodeNgramTable queryNodeTable cond12 cond23
 174     where
 175          cond12 (Node occId _ _ _ _ _ _, NodeNodeNgram occId' _ _ _)
 176                 = (.==) occId occId'
 177
 178          cond23 :: (NodeRead, (NodeRead, NodeNodeNgramReadNull)) -> Column PGBool
 179          cond23 (Node  docId _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ docId' _ _))
 180                 = (.||) ((.==) (toNullable docId) docId') (isNull docId')
 181
 182
 183 leftJoin3''' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
 184 leftJoin3''' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
 185     where
 186          cond12 (NodeNode favId _ _, Node favId' _ _ _ _ _ _)
 187                 = (.||) ((.==) favId (toNullable favId')) (isNull $ toNullable favId)
 188
 189          cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
 190          cond23 (Node  nId _ _ _ _ _ _, (NodeNode _ nId' _, Node _ _ _ _ _ _ _ ))
 191                 = ((.==) (nId) (nId'))
 192
 193
 194 -- getDocTest :: Connection -> IO [FacetDoc]
 195 -- getDocTest conn = runQuery conn selectDocFacet
 196
 197 -- | Building the facet
 198 -- selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 199 selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 200 selectDocFacet' _ _ = proc () -> do
 201         (n1,(nn,n2)) <- leftJoin3''' -< ()
 202         restrict -< (.&&) (node_parentId n1 .== (toNullable $ pgInt4 347476))
 203                           (node_typename n1 .== (pgInt4 4))
 204
 205         restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 15))
 206                           (isNull $ node_typename n2)
 207
 208         restrict -< (.||) (node_parentId n2 .== (toNullable $ pgInt4 347476))
 209                           (isNull $ node_parentId n2)
 210
 211         let isFav = ifThenElse (isNull $ nodeNode_score nn) (pgBool False) (pgBool True)
 212 --
 213         returnA  -< FacetDoc (node_id n1) (node_date n1) (node_hyperdata n1) (isFav) (pgInt4 1)
 214
 215