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
  15 {-# LANGUAGE Arrows                    #-}
  16 {-# LANGUAGE DeriveGeneric             #-}
  17 {-# LANGUAGE FlexibleContexts          #-}
  18 {-# LANGUAGE FlexibleInstances         #-}
  19 {-# LANGUAGE FunctionalDependencies    #-}
  20 {-# LANGUAGE MultiParamTypeClasses     #-}
  21 {-# LANGUAGE NoImplicitPrelude         #-}
  22 {-# LANGUAGE NoMonomorphismRestriction #-}
  23 {-# LANGUAGE OverloadedStrings    #-}
  24 {-# LANGUAGE TemplateHaskell           #-}
  25 ------------------------------------------------------------------------
  26 module Gargantext.Database.Facet
  27   where
  28 ------------------------------------------------------------------------
  29
  30 import Prelude hiding (null, id, map, sum, not, read)
  31 import Prelude (Enum, Bounded, minBound, maxBound)
  32 import GHC.Generics (Generic)
  33
  34 import Data.Aeson (FromJSON, ToJSON)
  35 import Data.Either(Either(Left))
  36 import Control.Arrow (returnA)
  37 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  38
  39 import Data.Aeson.TH (deriveJSON)
  40 import Data.Maybe (Maybe)
  41 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  42 import Data.Text (Text)
  43 import Data.Time (UTCTime)
  44 import Data.Time.Segment (jour)
  45 import Data.Swagger
  46
  47 import Database.PostgreSQL.Simple (Connection)
  48 import           Opaleye
  49 import qualified Opaleye.Internal.Unpackspec()
  50
  51 import Servant.API
  52 import Test.QuickCheck.Arbitrary
  53 import Test.QuickCheck (elements)
  54
  55 import Gargantext.Core.Types
  56 import Gargantext.Core.Utils.Prefix (unPrefix)
  57 import Gargantext.Database.NodeNode
  58 import Gargantext.Database.Node
  59 import Gargantext.Database.Queries
  60 import Gargantext.Database.Config (nodeTypeId)
  61 -- import Gargantext.Database.NodeNgram
  62
  63 ------------------------------------------------------------------------
  64 -- | DocFacet
  65
  66 -- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
  67 --    deriving (Show, Generic)
  68 --instance FromJSON Facet
  69 --instance ToJSON   Facet
  70
  71 type Favorite = Bool
  72 type Title    = Text
  73
  74 type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument Favorite Int
  75 type FacetSources = FacetDoc
  76 type FacetAuthors = FacetDoc
  77 type FacetTerms   = FacetDoc
  78
  79
  80
  81 data Facet id created title hyperdata favorite ngramCount =
  82      FacetDoc { facetDoc_id         :: id
  83               , facetDoc_created    :: created
  84               , facetDoc_title      :: title
  85               , facetDoc_hyperdata  :: hyperdata
  86               , facetDoc_favorite   :: favorite
  87               , facetDoc_ngramCount :: ngramCount
  88               } deriving (Show, Generic)
  89
  90 -- | JSON instance
  91
  92 $(deriveJSON (unPrefix "facetDoc_") ''Facet)
  93
  94 -- | Documentation instance
  95 instance ToSchema FacetDoc
  96
  97 -- | Mock and Quickcheck instances
  98
  99 instance Arbitrary FacetDoc where
 100     arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp fav ngramCount
 101                          | id'  <- [1..10]
 102                          , year <- [1990..2000]
 103                          , t    <- ["title", "another title"]
 104                          , hp   <- hyperdataDocuments
 105                          , fav  <- [True, False]
 106                          , ngramCount <- [3..100]
 107                          ]
 108
 109 -- Facets / Views for the Front End
 110 -- | Database instances
 111 $(makeAdaptorAndInstance "pFacetDoc" ''Facet)
 112 $(makeLensesWith abbreviatedFields   ''Facet)
 113
 114 type FacetDocRead = Facet (Column PGInt4       )
 115                           (Column PGTimestamptz)
 116                           (Column PGText       )
 117                           (Column PGJsonb      )
 118                           (Column PGBool)
 119                           (Column PGInt4       )
 120
 121 -----------------------------------------------------------------------
 122
 123 data FacetChart = FacetChart { facetChart_time  :: UTCTime'
 124                              , facetChart_count :: Double
 125                         }
 126         deriving (Show, Generic)
 127 $(deriveJSON (unPrefix "facetChart_") ''FacetChart)
 128 instance ToSchema FacetChart
 129
 130 instance Arbitrary FacetChart where
 131     arbitrary = FacetChart <$> arbitrary <*> arbitrary
 132
 133 -----------------------------------------------------------------------
 134 type Trash   = Bool
 135 data OrderBy =  DateAsc | DateDesc
 136              | TitleAsc | TitleDesc
 137              | FavDesc  | FavAsc
 138              deriving (Generic, Enum, Bounded, Read, Show)
 139              -- | NgramCoun
 140
 141 instance FromHttpApiData OrderBy
 142   where
 143     parseUrlPiece "DateAsc"  = pure DateAsc
 144     parseUrlPiece "DateDesc" = pure DateDesc
 145     parseUrlPiece "TitleAsc" = pure TitleAsc
 146     parseUrlPiece "TitleDesc" = pure TitleDesc
 147     parseUrlPiece "FavAsc"   = pure FavAsc
 148     parseUrlPiece "FavDesc"   = pure FavDesc
 149     parseUrlPiece _           = Left "Unexpected value of OrderBy"
 150
 151 instance ToParamSchema OrderBy
 152 instance FromJSON  OrderBy
 153 instance ToJSON    OrderBy
 154 instance ToSchema  OrderBy
 155 instance Arbitrary OrderBy
 156   where
 157     arbitrary = elements [minBound..maxBound]
 158
 159 viewDocuments :: CorpusId -> Trash -> NodeTypeId -> Query FacetDocRead
 160 viewDocuments cId t ntId = proc () -> do
 161   n  <- queryNodeTable -< ()
 162   nn <- queryNodeNodeTable -< ()
 163   restrict -< _node_id n .== nodeNode_node2_id nn
 164   restrict -< nodeNode_node1_id nn .== (pgInt4 cId)
 165   restrict -< _node_typename    n  .== (pgInt4 ntId)
 166   restrict -< nodeNode_delete   nn .== (pgBool t)
 167   returnA  -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nodeNode_favorite nn) (pgInt4 1)
 168
 169
 170 filterDocuments :: (PGOrd date, PGOrd title, PGOrd favorite) =>
 171      Maybe Gargantext.Core.Types.Offset
 172      -> Maybe Gargantext.Core.Types.Limit
 173      -> Maybe OrderBy
 174      -> Select (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
 175      -> Query  (Facet id (Column date) (Column title) hyperdata (Column favorite) ngramCount)
 176 filterDocuments o l order q = limit' l $ offset' o $ orderBy ordering q
 177   where
 178     ordering = case order of
 179       (Just DateAsc)   -> asc  facetDoc_created
 180
 181       (Just TitleAsc)  -> asc  facetDoc_title
 182       (Just TitleDesc) -> desc facetDoc_title
 183
 184       (Just FavAsc)    -> asc  facetDoc_favorite
 185       (Just FavDesc)   -> desc facetDoc_favorite
 186       _                -> desc facetDoc_created
 187
 188
 189 runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd [FacetDoc]
 190 runViewDocuments cId t o l order = mkCmd $ \c -> runViewDocuments' c cId t o l order
 191
 192 -- | TODO use only Cmd with Reader and delete function below
 193 runViewDocuments' :: Connection -> CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
 194 runViewDocuments' c cId t o l order = runQuery c ( filterDocuments o l order
 195                                                 $ viewDocuments cId t ntId)
 196   where
 197     ntId = nodeTypeId NodeDocument
 198
 199
 200
 201
 202 {-
 203 getDocFacet :: Connection -> NodeType -> Int -> Maybe NodeType
 204             -> Maybe Offset -> Maybe Limit
 205             -> IO [FacetDoc]
 206 getDocFacet conn parentType parentId nodeType maybeOffset maybeLimit =
 207     runQuery conn $ selectDocFacet parentType parentId nodeType maybeOffset maybeLimit
 208
 209 selectDocFacet :: NodeType -> ParentId -> Maybe NodeType
 210                -> Maybe Offset -> Maybe Limit
 211                -> Query FacetDocRead
 212 selectDocFacet pType parentId maybeNodeType maybeOffset maybeLimit =
 213         limit' maybeLimit $ offset' maybeOffset
 214                           $ orderBy (asc facetDoc_created)
 215                           $ selectDocFacet' pType parentId maybeNodeType
 216
 217
 218 -- | Left join to the favorites
 219 nodeNodeLeftJoin :: Query (NodeRead, NodeNodeReadNull)
 220 nodeNodeLeftJoin = leftJoin queryNodeTable queryNodeNodeTable (eqNode)
 221     where
 222         eqNode (Node n1 _ _ _ _ _ _, NodeNode _ n2 _ _ _ ) = ((.==) n1 n2)
 223
 224
 225 nodeNodeLeftJoin' :: (Column (Nullable PGInt4))
 226                   -> Query (NodeRead, NodeNodeReadNull)
 227 nodeNodeLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeTable (eqNode nId)
 228         where
 229             eqNode n (Node n1 _ _ _ _ _ _, NodeNode n1' n2 _ _ _)
 230                    = foldl (.&&) (pgBool True) [ ((.==) n1 n2)
 231                                                , ((.==) n1' n)
 232                                                ]
 233
 234 nodeNodeLeftJoin'' :: Query (NodeRead, NodeRead, NodeNodeRead)
 235 nodeNodeLeftJoin'' = join3 queryNodeTable queryNodeTable queryNodeNodeTable eqNode
 236         where
 237             eqNode (Node n1 _ _ _ _ _ _, Node n2 _ _ _ _ _ _, NodeNode n1' n2' _ _ _)
 238                    = foldl (.&&) (pgBool True) [ ((.==) n2 n2')
 239                                                , ((.==) (toNullable n1) n1')
 240                                                ]
 241
 242 -- | Left join to the ngram count per document
 243 nodeNodeNgramLeftJoin :: Query (NodeRead, NodeNodeNgramReadNull)
 244 nodeNodeNgramLeftJoin = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode)
 245      where
 246         eqNode (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' _ _ _) = ((.==) n1 n1')
 247
 248
 249 nodeNodeNgramLeftJoin' :: Column (Nullable PGInt4)
 250                        -> Query (NodeRead, NodeNodeNgramReadNull)
 251 nodeNodeNgramLeftJoin' nId = leftJoin queryNodeTable queryNodeNodeNgramTable (eqNode nId)
 252      where
 253         eqNode nId' (Node n1 _ _ _ _ _ _, NodeNodeNgram n1' n2 _ _)
 254                  = (.&&) ((.==) n1 n1')
 255                          ((.==) nId' (toNullable n2))
 256
 257
 258 leftJoin3 :: (Default NullMaker (columnsL1, nullableColumnsR) nullableColumnsR1,
 259               Default NullMaker columnsR nullableColumnsR,
 260               Default Unpackspec columnsR columnsR,
 261               Default Unpackspec nullableColumnsR nullableColumnsR,
 262               Default Unpackspec columnsL1 columnsL1,
 263               Default Unpackspec columnsL columnsL) =>
 264               Query columnsL1 -> Query columnsR -> Query columnsL
 265                 -> ((columnsL1, columnsR) -> Column PGBool)
 266                 -> ((columnsL, (columnsL1, nullableColumnsR)) -> Column PGBool)
 267                 -> Query (columnsL, nullableColumnsR1)
 268 leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
 269
 270
 271 leftJoin3' :: Query (NodeRead, (NodeReadNull, NodeNodeNgramReadNull))
 272 leftJoin3' = leftJoin3 queryNodeTable  queryNodeNodeNgramTable queryNodeTable cond12 cond23
 273     where
 274          cond12 (Node occId _ _ _ _ _ _, NodeNodeNgram occId' _ _ _)
 275                 = (.==) occId occId'
 276
 277          cond23 :: (NodeRead, (NodeRead, NodeNodeNgramReadNull)) -> Column PGBool
 278          cond23 (Node  docId _ _ _ _ _ _, (Node _ _ _ _ _ _ _, NodeNodeNgram _ docId' _ _))
 279                 = (.||) ((.==) (toNullable docId) docId') (isNull docId')
 280
 281
 282 leftJoin3''' :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
 283 leftJoin3''' = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
 284     where
 285          cond12 (NodeNode favId _ _ _ _, Node favId' _ _ _ _ _ _)
 286                 = (.||) ((.==) favId (toNullable favId')) (isNull $ toNullable favId)
 287
 288          cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
 289          cond23 (Node  nId _ _ _ _ _ _, (NodeNode _ nId' _ _ _, Node _ _ _ _ _ _ _ ))
 290                 = ((.==) (nId) (nId'))
 291
 292
 293 -- | Building the facet
 294 selectDocFacet' :: NodeType -> ParentId -> Maybe NodeType -> Query FacetDocRead
 295 selectDocFacet' _ pId _ = proc () -> do
 296         (n1,(nn,_n2)) <- leftJoin3''' -< ()
 297         restrict -< (.&&) (_node_parentId n1 .== (toNullable $ pgInt4 pId))
 298                           (_node_typename n1 .== (pgInt4 $ nodeTypeId NodeDocument))
 299
 300 --        restrict -< (.||) (node_typename n2 .== (toNullable $ pgInt4 $ nodeTypeId Favorites))
 301 --                          (isNull $ node_typename n2)
 302 --
 303 --        restrict -< (.||) (node_parentId n2 .== (toNullable $ pgInt4 $ nodeTypeId Favorites))
 304 --                          (isNull $ node_parentId n2)
 305
 306         let isFav = ifThenElse (isNull $ nodeNode_score nn) (pgBool False) (pgBool True)
 307
 308         returnA  -< FacetDoc (_node_id n1) (_node_date n1) (_node_hyperdata n1) (isFav) (pgInt4 1)
 309
 310 -}