Merge remote-tracking branch 'origin/dev-hackathon-fixes' into dev
[gargantext.git] / src / Gargantext / Database / Query / Facet.hs
index 7a025185152a14192c9f88ddb1c7b229c7d55979..54b862e820c495aa4b86be72050442ab6d6cab7e 100644 (file)
@@ -8,9 +8,6 @@ Stability   : experimental
 Portability : POSIX
 -}
 
-{-# OPTIONS_GHC -fno-warn-orphans        #-}
-
-
 {-# LANGUAGE Arrows                    #-}
 {-# LANGUAGE FunctionalDependencies    #-}
 {-# LANGUAGE QuasiQuotes               #-}
@@ -21,6 +18,7 @@ Portability : POSIX
 module Gargantext.Database.Query.Facet
   ( runViewAuthorsDoc
   , runViewDocuments
+--   , viewDocuments'
   , runCountDocuments
   , filterWith
 
@@ -40,208 +38,32 @@ module Gargantext.Database.Query.Facet
   )
   where
 
-import Control.Arrow (returnA)
+import Control.Arrow (returnA, (>>>))
 import Control.Lens ((^.))
-import Data.Aeson (FromJSON, ToJSON)
-import Data.Aeson.TH (deriveJSON)
---import qualified Database.PostgreSQL.Simple as DPS
---import Database.PostgreSQL.Simple.SqlQQ (sql)
-import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
-import Data.Swagger
 import qualified Data.Text as T
-import Data.Time (UTCTime)
-import Data.Time.Segment (jour)
 import Opaleye
 import Protolude hiding (null, map, sum, not)
-import Servant.API
-import Test.QuickCheck (elements)
-import Test.QuickCheck.Arbitrary
 import qualified Opaleye.Internal.Unpackspec()
 
 import Gargantext.Core
 import Gargantext.Core.Types
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
--- import Gargantext.Database.Action.TSQuery (toTSQuery)
-import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Query.Filter
 import Gargantext.Database.Query.Join (leftJoin5)
 import Gargantext.Database.Query.Table.Ngrams
-import Gargantext.Database.Query.Table.Node (queryNodeSearchTable)
-import Gargantext.Database.Query.Table.NodeNode
-import Gargantext.Database.Query.Table.NodeNodeNgrams
+import Gargantext.Database.Query.Table.Context
+import Gargantext.Database.Query.Facet.Types
+import Gargantext.Database.Query.Table.ContextNodeNgrams
+import Gargantext.Database.Query.Table.NodeContext (queryNodeContextTable)
 import Gargantext.Database.Prelude
+import Gargantext.Database.Schema.Context
 import Gargantext.Database.Schema.Node
+import Gargantext.Database.Schema.NodeContext
 import Gargantext.Prelude (printDebug)
 
 ------------------------------------------------------------------------
--- | DocFacet
-
--- data Facet = FacetDoc | FacetSources | FacetAuthors | FacetTerms
---    deriving (Show, Generic)
---instance FromJSON Facet
---instance ToJSON   Facet
-
-type Category = Int
-type Score    = Double
-type Title    = Text
-
--- TODO remove Title
-type FacetDoc = Facet NodeId UTCTime Title HyperdataDocument (Maybe Category) (Maybe Double) (Maybe Score)
--- type FacetSources = FacetDoc
--- type FacetAuthors = FacetDoc
--- type FacetTerms   = FacetDoc
-
-
-data Facet id created title hyperdata category ngramCount score =
-     FacetDoc { facetDoc_id         :: id
-              , facetDoc_created    :: created
-              , facetDoc_title      :: title
-              , facetDoc_hyperdata  :: hyperdata
-              , facetDoc_category   :: category
-              , facetDoc_ngramCount :: ngramCount
-              , facetDoc_score      :: score
-              } deriving (Show, Generic)
-{- | TODO after demo
-data Facet id date hyperdata score = 
-     FacetDoc { facetDoc_id        :: id
-              , facetDoc_date      :: date
-              , facetDoc_hyperdata :: hyperdata
-              , facetDoc_score     :: score
-              } deriving (Show, Generic)
--}
-
-data Pair i l = Pair {
-    _p_id    :: i
-  , _p_label :: l
-  } deriving (Show, Generic)
-$(deriveJSON (unPrefix "_p_") ''Pair)
-$(makeAdaptorAndInstance "pPair" ''Pair)
-
-instance (Typeable i, Typeable l, ToSchema i, ToSchema l) => ToSchema (Pair i l) where
-  declareNamedSchema = wellNamedSchema "_p_"
-instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
-  arbitrary = Pair <$> arbitrary <*> arbitrary
-
-data FacetPaired id date hyperdata score =
-  FacetPaired { _fp_id        :: id
-              , _fp_date      :: date
-              , _fp_hyperdata :: hyperdata
-              , _fp_score     :: score }
-  deriving (Show, Generic)
-$(deriveJSON (unPrefix "_fp_") ''FacetPaired)
-$(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
-
-
-
-instance ( ToSchema id
-         , ToSchema date
-         , ToSchema hyperdata
-         , ToSchema score
-         , Typeable id
-         , Typeable date
-         , Typeable hyperdata
-         , Typeable score
-         ) => ToSchema (FacetPaired id date hyperdata score) where
-  declareNamedSchema = wellNamedSchema "_fp_"
-
-instance ( Arbitrary id
-         , Arbitrary date
-         , Arbitrary hyperdata
-         , Arbitrary score
-         ) => Arbitrary (FacetPaired id date hyperdata score) where
-  arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
-
-type FacetPairedRead = FacetPaired (Column PGInt4       )
-                                   (Column PGTimestamptz)
-                                   (Column PGJsonb      )
-                                   (Column PGInt4       )
-
-type FacetPairedReadNull = FacetPaired (Column (Nullable PGInt4)       )
-                                       (Column (Nullable PGTimestamptz))
-                                       (Column (Nullable PGJsonb)      )
-                                       (Column (Nullable PGInt4)       )
-
-type FacetPairedReadNullAgg = FacetPaired (Aggregator (Column (Nullable PGInt4)       )
-                                                      (Column (Nullable PGInt4)       ) 
-                                          )
-                                          (Aggregator (Column (Nullable PGTimestamptz))
-                                                      (Column (Nullable PGTimestamptz))
-
-                                          )
-                                          (Aggregator (Column (Nullable PGJsonb)      )
-                                                      (Column (Nullable PGJsonb)      )
-                                          )
-                                          (Aggregator (Column (Nullable PGInt4)       )
-                                                      (Column (Nullable PGInt4)       )
-                                          )
-
-
-
-
--- | JSON instance
-$(deriveJSON (unPrefix "facetDoc_") ''Facet)
-
--- | Documentation instance
-instance ToSchema FacetDoc where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "facetDoc_")
-
--- | Mock and Quickcheck instances
-instance Arbitrary FacetDoc where
-    arbitrary = elements [ FacetDoc id' (jour year 01 01) t hp (Just cat) (Just ngramCount) (Just score)
-                         | id'  <- [1..10]
-                         , year <- [1990..2000]
-                         , t    <- ["title", "another title"]
-                         , hp   <- arbitraryHyperdataDocuments
-                         , cat  <- [0..2]
-                         , ngramCount <- [3..100]
-                         , score <- [3..100]
-                         ]
-
--- Facets / Views for the Front End
--- | Database instances
-$(makeAdaptorAndInstance "pFacetDoc" ''Facet)
--- $(makeLensesWith abbreviatedFields   ''Facet)
-
-type FacetDocRead = Facet (Column PGInt4       )
-                          (Column PGTimestamptz)
-                          (Column PGText       )
-                          (Column PGJsonb      )
-                          (Column (Nullable PGInt4)) -- Category
-                          (Column (Nullable PGFloat8)) -- Ngrams Count
-                          (Column (Nullable PGFloat8)) -- Score
-
------------------------------------------------------------------------
------------------------------------------------------------------------
-data OrderBy =  DateAsc   | DateDesc
-             | TitleAsc   | TitleDesc
-             | ScoreDesc  | ScoreAsc
-             | SourceAsc  | SourceDesc
-             deriving (Generic, Enum, Bounded, Read, Show)
-
-instance FromHttpApiData OrderBy
-  where
-    parseUrlPiece "DateAsc"    = pure DateAsc
-    parseUrlPiece "DateDesc"   = pure DateDesc
-    parseUrlPiece "TitleAsc"   = pure TitleAsc
-    parseUrlPiece "TitleDesc"  = pure TitleDesc
-    parseUrlPiece "ScoreAsc"   = pure ScoreAsc
-    parseUrlPiece "ScoreDesc"  = pure ScoreDesc
-    parseUrlPiece "SourceAsc"  = pure SourceAsc
-    parseUrlPiece "SourceDesc" = pure SourceDesc
-    parseUrlPiece _            = Left "Unexpected value of OrderBy"
-
-instance ToParamSchema OrderBy
-instance FromJSON  OrderBy
-instance ToJSON    OrderBy
-instance ToSchema  OrderBy
-instance Arbitrary OrderBy
-  where
-    arbitrary = elements [minBound..maxBound]
 
 
 -- TODO-SECURITY check
-
---{-
 runViewAuthorsDoc :: HasDBid NodeType
                   => ContactId
                   -> IsTrash
@@ -258,46 +80,40 @@ viewAuthorsDoc :: HasDBid NodeType
                => ContactId
                -> IsTrash
                -> NodeType
-               -> Query FacetDocRead
+               -> Select FacetDocRead
 viewAuthorsDoc cId _ nt = proc () -> do
   (doc,(_,(_,(_,contact')))) <- queryAuthorsDoc      -< ()
 
-  {-nn         <- queryNodeNodeTable -< ()
-  restrict -< nn_node1_id nn .== _node_id doc
-  -- restrict -< nn_delete   nn .== (pgBool t)
-  -}
-
   restrict -< _node_id   contact'  .== (toNullable $ pgNodeId cId)
   restrict -< _node_typename doc   .== (sqlInt4 $ toDBid nt)
 
-  returnA  -< FacetDoc (_node_id        doc)
-                       (_node_date      doc)
-                       (_node_name      doc)
-                       (_node_hyperdata doc)
-                       (toNullable $ sqlInt4 1)
-                       (toNullable $ pgDouble 1)
-                       (toNullable $ pgDouble 1)
+  returnA  -< FacetDoc { facetDoc_id         = _node_id        doc
+                       , facetDoc_created    = _node_date      doc
+                       , facetDoc_title      = _node_name      doc
+                       , facetDoc_hyperdata  = _node_hyperdata doc
+                       , facetDoc_category   = toNullable $ sqlInt4 1
+                       , facetDoc_ngramCount = toNullable $ sqlDouble 1
+                       , facetDoc_score      = toNullable $ sqlDouble 1 }
 
-queryAuthorsDoc :: Query (NodeRead, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull))))
-queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNodeNgramsTable queryNgramsTable queryNodeNodeNgramsTable queryNodeTable cond12 cond23 cond34 cond45
+queryAuthorsDoc :: Select (NodeRead, (ContextNodeNgramsReadNull, (NgramsReadNull, (ContextNodeNgramsReadNull, NodeReadNull))))
+queryAuthorsDoc = leftJoin5 queryNodeTable queryContextNodeNgramsTable queryNgramsTable queryContextNodeNgramsTable queryNodeTable cond12 cond23 cond34 cond45
     where
-         cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
-         cond12 (nodeNgram, doc) =  _node_id                  doc
-                                .== _nnng_node1_id nodeNgram
+         cond12 :: (ContextNodeNgramsRead, NodeRead) -> Column SqlBool
+         cond12 (nodeNgram, doc) =  _node_id doc
+                                .== _cnng_context_id nodeNgram
 
-         cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
+         cond23 :: (NgramsRead, (ContextNodeNgramsRead, NodeReadNull)) -> Column SqlBool
          cond23 (ngrams', (nodeNgram, _)) =  ngrams'^.ngrams_id
-                                        .== _nnng_ngrams_id nodeNgram
+                                        .== _cnng_ngrams_id nodeNgram
 
-         cond34 :: (NodeNodeNgramsRead, (NgramsRead, (NodeNodeNgramsReadNull, NodeReadNull))) -> Column PGBool
-         cond34 (nodeNgram2, (ngrams', (_,_)))= ngrams'^.ngrams_id .== _nnng_ngrams_id       nodeNgram2
+         cond34 :: (ContextNodeNgramsRead, (NgramsRead, (ContextNodeNgramsReadNull, NodeReadNull))) -> Column SqlBool
+         cond34 (nodeNgram2, (ngrams', (_,_)))= ngrams'^.ngrams_id .== _cnng_ngrams_id       nodeNgram2
 
-         cond45 :: (NodeRead, (NodeNodeNgramsRead, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))) -> Column PGBool
-         cond45 (contact', (nodeNgram2', (_, (_,_)))) = _node_id  contact'  .== _nnng_node1_id         nodeNgram2'
+         cond45 :: (NodeRead, (ContextNodeNgramsRead, (NgramsReadNull, (ContextNodeNgramsReadNull, NodeReadNull)))) -> Column SqlBool
+         cond45 (contact', (nodeNgram2', (_, (_,_)))) = _node_id  contact'  .== _cnng_context_id         nodeNgram2'
 
---}
-------------------------------------------------------------------------
 
+------------------------------------------------------------------------
 -- TODO-SECURITY check
 runViewDocuments :: HasDBid NodeType
                  => CorpusId
@@ -306,69 +122,71 @@ runViewDocuments :: HasDBid NodeType
                  -> Maybe Limit
                  -> Maybe OrderBy
                  -> Maybe Text
+                 -> Maybe Text
                  -> Cmd err [FacetDoc]
-runViewDocuments cId t o l order query = do
---  docs <- runPGSQuery viewDocuments'
---    ( cId
---    , ntId
---    , (if t then 0 else 1) :: Int
---    , fromMaybe "" query
---    , fromMaybe "" query)
---  pure $ (\(id, date, name', hyperdata, category, score) -> FacetDoc id date name' hyperdata category score score) <$> docs
+runViewDocuments cId t o l order query year = do
     printDebug "[runViewDocuments] sqlQuery" $ showSql sqlQuery
     runOpaQuery $ filterWith o l order sqlQuery
   where
-    ntId = toDBid NodeDocument
-    sqlQuery = viewDocuments cId t ntId query
---    viewDocuments' :: DPS.Query
---    viewDocuments' = [sql|
---      SELECT n.id, n.date, n.name, n.hyperdata, nn.category, nn.score
---        FROM nodes AS n
---        JOIN nodes_nodes AS nn
---        ON n.id = nn.node2_id
---        WHERE nn.node1_id = ?  -- corpusId
---          AND n.typename = ?   -- NodeTypeId
---          AND nn.category = ?  -- isTrash or not
---          AND (n.search @@ to_tsquery(?) OR ? = '')  -- query with an OR hack for empty to_tsquery('') results
---      |]
-
-runCountDocuments :: HasDBid NodeType => CorpusId -> IsTrash -> Maybe Text -> Cmd err Int
-runCountDocuments cId t mQuery = do
+    sqlQuery = viewDocuments cId t (toDBid NodeDocument) query year
+
+runCountDocuments :: HasDBid NodeType => CorpusId -> IsTrash -> Maybe Text -> Maybe Text -> Cmd err Int
+runCountDocuments cId t mQuery mYear = do
   runCountOpaQuery sqlQuery
   where
-    sqlQuery = viewDocuments cId t (toDBid NodeDocument) mQuery
+    sqlQuery = viewDocuments cId t (toDBid NodeDocument) mQuery mYear
 
 
 viewDocuments :: CorpusId
               -> IsTrash
               -> NodeTypeId
               -> Maybe Text
-              -> Query FacetDocRead
-viewDocuments cId t ntId mQuery = proc () -> do
-  --n  <- queryNodeTable     -< ()
-  n  <- queryNodeSearchTable -< ()
-  nn <- queryNodeNodeTable -< ()
-  restrict -< n^.ns_id       .== nn^.nn_node2_id
-  restrict -< nn^.nn_node1_id  .== (pgNodeId cId)
-  restrict -< n^.ns_typename .== (sqlInt4 ntId)
-  restrict -< if t then nn^.nn_category .== (sqlInt4 0)
-                   else nn^.nn_category .>= (sqlInt4 1)
-                       
-  let query = (fromMaybe "" mQuery)
-      -- iLikeQuery = T.intercalate "" ["%", query, "%"]
-  -- restrict -< (n^.node_name) `ilike` (sqlStrictText iLikeQuery)
-  restrict -< if query == ""
-    then pgBool True
-    --else (n^.ns_search) @@ (pgTSQuery (T.unpack query))
-    else (n^.ns_search) @@ (plaintoTSQuery $ T.unpack query)
-  returnA  -< FacetDoc (_ns_id        n)
-                       (_ns_date      n)
-                       (_ns_name      n)
-                       (_ns_hyperdata n)
-                       (toNullable $ nn^.nn_category)
-                       (toNullable $ nn^.nn_score)
-                       (toNullable $ nn^.nn_score)
+              -> Maybe Text
+              -> Select FacetDocRead
+viewDocuments cId t ntId mQuery mYear = viewDocumentsQuery cId t ntId mQuery mYear >>> proc (c, nc) -> do
+  returnA  -< FacetDoc { facetDoc_id         = _cs_id        c
+                       , facetDoc_created    = _cs_date      c
+                       , facetDoc_title      = _cs_name      c
+                       , facetDoc_hyperdata  = _cs_hyperdata c
+                       , facetDoc_category   = toNullable $ nc^.nc_category
+                       , facetDoc_ngramCount = toNullable $ nc^.nc_score
+                       , facetDoc_score      = toNullable $ nc^.nc_score
+                       }
+
+viewDocumentsQuery :: CorpusId
+                   -> IsTrash
+                   -> NodeTypeId
+                   -> Maybe Text
+                   -> Maybe Text
+                   -> Select (ContextSearchRead, NodeContextRead)
+viewDocumentsQuery cId t ntId mQuery mYear = proc () -> do
+  c  <- queryContextSearchTable -< ()
+  nc <- queryNodeContextTable   -< ()
+  restrict -< c^.cs_id         .== nc^.nc_context_id
+  restrict -< nc^.nc_node_id   .== (pgNodeId cId)
+  restrict -< c^.cs_typename   .== (sqlInt4 ntId)
+  restrict -< if t then nc^.nc_category .== (sqlInt4 0)
+                   else nc^.nc_category .>= (sqlInt4 1)
+
+  let
+    query         = (fromMaybe "" mQuery)
+    year          = (fromMaybe "" mYear)
+    iLikeQuery    = T.intercalate "" ["%", query, "%"]
+    abstractLHS h = fromNullable (sqlStrictText "")
+                  $ toNullable h .->> (sqlStrictText "abstract")
+    yearLHS h     = fromNullable (sqlStrictText "")
+                  $ toNullable h .->> (sqlStrictText "publication_year")
+
+  restrict -<
+    if query == "" then sqlBool True
+      else  ((c^.cs_name) `ilike` (sqlStrictText iLikeQuery))
+        .|| ((abstractLHS (c^.cs_hyperdata)) `ilike` (sqlStrictText iLikeQuery))
+  restrict -<
+    if year == "" then sqlBool True
+      else (yearLHS (c^.cs_hyperdata)) .== (sqlStrictText year)
+
+  returnA -< (c, nc)
+
 
 ------------------------------------------------------------------------
 filterWith :: (SqlOrd date, SqlOrd title, SqlOrd category, SqlOrd score, hyperdata ~ Column SqlJsonb) =>
@@ -395,9 +213,12 @@ orderWith (Just ScoreDesc) = descNullsLast facetDoc_score
 orderWith (Just SourceAsc)  = asc  facetDoc_source
 orderWith (Just SourceDesc) = desc facetDoc_source
 
+orderWith (Just TagAsc)     = asc  facetDoc_category
+orderWith (Just TagDesc)    = desc facetDoc_category
+
 orderWith _                = asc facetDoc_created
 
 facetDoc_source :: SqlIsJson a
                 => Facet id created title (Column a) favorite ngramCount score
-                -> Column (Nullable PGText)
-facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> pgString "source"
+                -> Column (Nullable SqlText)
+facetDoc_source x = toNullable (facetDoc_hyperdata x) .->> sqlString "source"