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 where
  25 ------------------------------------------------------------------------
  26
  27 import Prelude hiding (null, id, map, sum, not)
  28 import GHC.Generics (Generic)
  29
  30 -- import Data.Aeson (Value)
  31 import Control.Arrow (returnA)
  32 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  33
  34 import Data.Aeson.TH (deriveJSON)
  35 import Data.Maybe (Maybe)
  36 import Data.Profunctor.Product.Default (Default)
  37 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  38 import Data.Time (UTCTime)
  39 import Data.Time.Segment (jour)
  40 import Data.Swagger
  41
  42 import           Database.PostgreSQL.Simple (Connection)
  43 import           Opaleye
  44 import           Opaleye.Internal.Join (NullMaker)
  45 import qualified Opaleye.Internal.Unpackspec()
  46
  47 import Test.QuickCheck.Arbitrary
  48 import Test.QuickCheck (elements)
  49
  50 import Gargantext.Types
  51 import Gargantext.Types.Node (NodeType)
  52 import Gargantext.Database.NodeNode
  53 import Gargantext.Database.NodeNodeNgram
  54 import Gargantext.Database.Node
  55 import Gargantext.Database.Queries
  56 import Gargantext.Utils.Prefix (unPrefix)
  57 -- import Gargantext.Database.NodeNgram
  58
  59 ------------------------------------------------------------------------
  60 ------------------------------------------------------------------------
  61
  62 -- | DocFacet
  63 --type FacetDoc = Facet NodeId UTCTime HyperdataDocument Bool -- Double
  64 --
  65 --data Facet id created hyperdata favorite  =
  66 --     FacetDoc { facetDoc_id         :: id
  67 --              , facetDoc_created    :: created
  68 --              , facetDoc_hyperdata  :: hyperdata
  69 --              , facetDoc_favorite   :: favorite
  70 --              } deriving (Show, Generic)
  71 -- $(deriveJSON (unPrefix "facetDoc_") ''Facet)
  72 --
  73 --instance Arbitrary FacetDoc where
  74 --    arbitrary = elements [ FacetDoc id' (jour year 01 01) hp fav
  75 --                         | id'  <- [   1..10   ]
  76 --                         , year <- [1990..2000 ]
  77 --                         , fav  <- [True, False]
  78 --                         , hp   <- hyperdataDocuments
  79 --                         ]
  80 --
  81 --instance ToSchema FacetDoc
  82 --
  83 ---- Facets / Views for the Front End
  84 --type FacetDocRead  = Facet (Column PGInt4       )
  85 --                           (Column PGTimestamptz)
  86 --                           (Column PGJsonb      )
  87 --                           (Column PGBool       ) -- (Column PGFloat8)
  88 --
  89 -- $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
  90 -- $(makeLensesWith abbreviatedFields   ''Facet)
  91 --
  92 ------------------------------------------------------------------------
  93 type FacetDoc = Facet NodeId UTCTime HyperdataDocument Bool Int
  94
  95 data Facet id created hyperdata favorite ngramCount =
  96      FacetDoc { facetDoc_id         :: id
  97                , facetDoc_created    :: created
  98                , facetDoc_hyperdata  :: hyperdata
  99                , facetDoc_favorite   :: favorite
 100                , facetDoc_ngramCount :: ngramCount
 101                } deriving (Show, Generic)
 102
 103 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
 104
 105 instance Arbitrary FacetDoc where
 106     arbitrary = elements [ FacetDoc id' (jour year 01 01) hp fav ngramCount
 107                          | id'  <- [1..10]
 108                          , year <- [1990..2000]
 109                          , hp   <- hyperdataDocuments
 110                          , fav  <- [True, False]
 111                          , ngramCount <- [3..100]
 112                          ]
 113
 114 -- Facets / Views for the Front End
 115 type FacetDocRead = Facet (Column PGInt4       )
 116                           (Column PGTimestamptz)
 117                           (Column PGJsonb      )
 118                           (Column PGBool       )
 119                           (Column PGInt4       )
 120
 121 instance ToSchema FacetDoc
 122
 123
 124 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
 125 $(makeLensesWith abbreviatedFields   ''Facet)
 126
 127 ------------------------------------------------------------------------
 128
 129
 130 getDocFacet :: Connection -> Int -> Maybe NodeType
 131             -> Maybe Offset -> Maybe Limit
 132             -> IO [FacetDoc]
 133 getDocFacet conn parentId nodeType maybeOffset maybeLimit =
 134     runQuery conn $ selectDocFacet parentId nodeType maybeOffset maybeLimit
 135
 136 selectDocFacet :: ParentId -> Maybe NodeType
 137                -> Maybe Offset -> Maybe Limit
 138                -> Query FacetDocRead
 139 selectDocFacet parentId maybeNodeType maybeOffset maybeLimit =
 140         limit' maybeLimit $ offset' maybeOffset
 141                           $ orderBy (asc facetDoc_created)
 142                           $ selectDocFacet' parentId maybeNodeType
 143
 144
 145 -- | Left join to the favorites
 146 nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
 147 nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
 148     where
 149         eqNode (Node n1 _ _ _ _ _ _, NodeNode _ n2 _) = ((.==) n1 n2)
 150
 151
 152 nodeNodeLeftJoin' :: (Column (Nullable PGInt4))
 153                   -> Query (NodeRead, NodeNodeReadNull)
 154 nodeNodeLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeTable (eqNode nId)
 155         where
 156             eqNode n (Node n1 _ _ _ _ _ _, NodeNode n1' n2 _)
 157                    = foldl (.&&) (pgBool True) [ ((.==) n1 n2)
 158                                                , ((.==) n1' n)
 159                                                ]
 160
 161 nodeNodeLeftJoin'' :: Query (NodeRead, NodeRead, NodeNodeRead)
 162 nodeNodeLeftJoin'' = join3 queryNodeTable queryNodeTable queryNodeNodeTable eqNode
 163         where
 164             eqNode (Node n1 _ _ _ _ _ _, Node n2 _ _ _ _ _ _, NodeNode n1' n2' _)
 165                    = foldl (.&&) (pgBool True) [ ((.==) n2 n2')
 166                                                , ((.==) (toNullable n1) n1')
 167                                                ]
 168
 169 -- | Left join to the ngram count per document
 170 nodeNodeNgramLeftJoin :: Query (NodeRead, NodeNodeNgramReadNull)
 171 nodeNodeNgramLeftJoin = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode)
 172      where
 173         eqNode (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' _ _ _) = ((.==) n1 n1')
 174
 175
 176 nodeNodeNgramLeftJoin' :: Column (Nullable PGInt4)
 177                        -> Query (NodeRead, NodeNodeNgramReadNull)
 178 nodeNodeNgramLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode nId)
 179      where
 180         eqNode nId' (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' n2 _ _)
 181                  = (.&&) ((.==) n1 n1')
 182                          ((.==) nId' (toNullable n2))
 183
 184
 185 leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
 186               Default NullMaker columnsR nullableColumnsR,
 187               Default Unpackspec columnsR columnsR,
 188               Default Unpackspec nullableColumnsR nullableColumnsR,
 189               Default Unpackspec columnsL1 columnsL1,
 190               Default Unpackspec columnsL columnsL) =>
 191               Query columnsL1 -> Query columnsR -> Query columnsL
 192                 -> ((columnsL1, columnsR) -> Column PGBool)
 193                 -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
 194                 -> Query (columnsL, nullableColumnsR1)
 195 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
 196
 197
 198 leftJoin3' :: Query (NodeRead, (NodeReadNull, NodeNodeNgramReadNull))
 199 leftJoin3' = leftJoin3 queryNodeTable  queryNodeNodeNgramTable queryNodeTable cond12 cond23
 200     where
 201          cond12 (Node occId _ _ _ _ _ _, NodeNodeNgram occId' _ _ _)
 202                 = (.==) occId occId'
 203
 204          cond23 :: (NodeRead, (NodeRead, NodeNodeNgramReadNull)) -> Column PGBool
 205          cond23 (Node  docId _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ docId' _ _))
 206                 = (.||) ((.==) (toNullable docId) docId') (isNull docId')
 207
 208
 209 leftJoin3''' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
 210 leftJoin3''' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
 211     where
 212          cond12 (NodeNode favId _ _, Node favId' _ _ _ _ _ _)
 213                 = (.||) ((.==) favId (toNullable favId')) (isNull $ toNullable favId)
 214
 215          cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
 216          cond23 (Node  nId _ _ _ _ _ _, (NodeNode _ nId' _, Node _ _ _ _ _ _ _ ))
 217                 = ((.==) (nId) (nId'))
 218
 219
 220 -- getDocTest :: Connection -> IO [FacetDoc]
 221 -- getDocTest conn = runQuery conn selectDocFacet
 222
 223 -- | Building the facet
 224 -- selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 225 selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 226 selectDocFacet' _ _ = proc () -> do
 227         (n1,(nn,n2)) <- leftJoin3''' -< ()
 228         restrict -< (.&&) (node_parentId n1 .== (toNullable $ pgInt4 347476))
 229                           (node_typename n1 .== (pgInt4 4))
 230
 231         restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 15))
 232                           (isNull $ node_typename n2)
 233
 234         restrict -< (.||) (node_parentId n2 .== (toNullable $ pgInt4 347476))
 235                           (isNull $ node_parentId n2)
 236
 237         let isFav = ifThenElse (isNull $ nodeNode_score nn) (pgBool False) (pgBool True)
 238 --
 239         returnA  -< FacetDoc (node_id n1) (node_date n1) (node_hyperdata n1) (isFav) (pgInt4 1)
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253 --
 254 --
 255 --selectDocFacet' :: ParentId -> Maybe NodeType -> Query FacetDocRead
 256 --selectDocFacet' parentId _ = proc () -> do
 257 --    node <- (proc () -> do
 258 --
 259 --            -- Favorite Column
 260 --            -- (Node docId docTypeId _ docParentId _ created docHyperdata, (Node _ favTypeId _ favParentId _ _ _, NodeNode _ docId' _))  <- leftJoin3'' -< ()
 261 --            (Node docId docTypeId _ docParentId _ created docHyperdata, (NodeNode _ docId' _, (Node _ favTypeId _ favParentId _ _ _)))  <- leftJoin3''' -< ()
 262 --
 263 --            restrict -< docTypeId .== (pgInt4 15) .&& docParentId .== (toNullable $ pgInt4 parentId)
 264 --
 265 --            -- select nn.score from nodes n left join nodes_nodes nn on n.id = nn.node2_id where n.typename =4;
 266 --            -- Selecting the documents and joining Favorite Node
 267 --
 268 --            restrict -< favParentId .== (toNullable $ pgInt4 parentId) .&& favTypeId .== (toNullable 4)
 269 --
 270 --            -- let docTypeId'' = maybe 0 nodeTypeId (Just Document)
 271 --
 272 --            -- Getting favorite data
 273 --            let isFav = ifThenElse (isNull docId') (pgBool False) (pgBool True)
 274 --            -- Ngram count by document
 275 --            -- Counting the ngram
 276 --            -- (Node occId occTypeId _ _ _ _ _, NodeNode _ _ _ count) <- nodeNodeNgramLeftJoin -< ()
 277 --            -- restrict -< occId .== 347540
 278 --
 279 --            --returnA  -< (FacetDoc n_id hyperdata isFav ngramCount)) -< ()
 280 --            returnA  -< (FacetDoc docId created docHyperdata isFav)) -< ()
 281 --    returnA -< node
 282 --