Skip to content

H
haskell-gargantext
Commit 25f2808e authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[Community] Query search contact with text query on documents

parent 24e7808e
Show whitespace changes
Inline Side-by-side
Showing with 111 additions and 128 deletions
src/Gargantext/API/Search.hs
View file @ 25f2808e
......@@ -28,7 +28,7 @@ import Gargantext.API.Prelude (GargServer)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Query.Facet
import Gargantext.Database.Action.Search
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataContact)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Prelude
import Servant
......@@ -60,7 +60,7 @@ instance ToSchema SearchDocResults where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "sdr_")
data SearchPairedResults =
SearchPairedResults { spr_results :: [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]] }
SearchPairedResults { spr_results :: [FacetPaired Int UTCTime HyperdataContact Int] }
deriving (Generic)
$(deriveJSON (unPrefix "spr_") ''SearchPairedResults)
......@@ -89,12 +89,12 @@ searchDocs nId (SearchQuery q) o l order =
-----------------------------------------------------------------------
type SearchPairsAPI = Summary ""
:> "list"
:> Capture "list" ListId
:> Capture "annuaire" AnnuaireId
:> SearchAPI SearchPairedResults
searchPairs :: NodeId -> GargServer SearchPairsAPI
searchPairs pId lId (SearchQuery q) o l order =
SearchPairedResults <$> searchInCorpusWithContacts pId lId q o l order
searchPairs pId aId (SearchQuery q) o l order =
SearchPairedResults <$> searchInCorpusWithContacts pId aId q o l order
-----------------------------------------------------------------------
src/Gargantext/Database.hs
View file @ 25f2808e
......@@ -33,11 +33,17 @@ import Gargantext.Database.Query.Table.NodeNode
class InsertDB a where
insertDB :: a -> Cmd err Int64
insertDB :: a -> Cmd err Int
{-
class DeleteDB a where
deleteDB :: a -> Cmd err Int
-}
instance InsertDB [NodeNode] where
insertDB = insertNodeNode
{-
instance InsertDB [Node a] where
insertDB = insertNodes'
......
src/Gargantext/Database/Action/Flow.hs
View file @ 25f2808e
......@@ -68,7 +68,7 @@ import Gargantext.Database.Action.Flow.Utils (insertDocNgrams)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
import Gargantext.Database.Query.Tree.Root (getOrMkRoot, getOrMk_RootWithCorpus)
import Gargantext.Database.Action.Search (searchInDatabase)
import Gargantext.Database.Action.Search (searchDocInDatabase)
import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Admin.Types.Hyperdata
......@@ -126,7 +126,7 @@ getDataText (InternalOrigin _) _la q _li = do
(UserName userMaster)
(Left "")
(Nothing :: Maybe HyperdataCorpus)
ids <- map fst <$> searchInDatabase cId (stemIt q)
ids <- map fst <$> searchDocInDatabase cId (stemIt q)
pure $ DataOld ids
-------------------------------------------------------------------------------
......
src/Gargantext/Database/Action/Flow/Pairing.hs
View file @ 25f2808e
......@@ -67,8 +67,7 @@ pairMaps m1 m2 =
pairing :: AnnuaireId -> CorpusId -> ListId -> Cmd err Int
pairing a c l = do
dataPaired <- dataPairing a (c,l,Authors) lastName toLower
r <- insertDB $ prepareInsert dataPaired
pure (fromIntegral r)
insertDB $ prepareInsert dataPaired
dataPairing :: AnnuaireId
......
src/Gargantext/Database/Action/Search.hs
View file @ 25f2808e
......@@ -27,11 +27,12 @@ import Opaleye hiding (Query, Order)
import qualified Opaleye as O hiding (Order)
import Gargantext.Core.Types
import Gargantext.Database.Query.Filter
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..), HyperdataContact(..))
import Gargantext.Database.Admin.Types.Node (NodeType(..))
import Gargantext.Database.Query.Facet
import Gargantext.Database.Query.Join (leftJoin6)
import Gargantext.Database.Query.Join (leftJoin6, leftJoin5)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.NodeNode
import Gargantext.Database.Query.Table.NodeNodeNgrams
......@@ -42,14 +43,14 @@ import Gargantext.Prelude
import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
------------------------------------------------------------------------
searchInDatabase :: ParentId
searchDocInDatabase :: ParentId
-> Text
-> Cmd err [(NodeId, HyperdataDocument)]
searchInDatabase p t = runOpaQuery (queryInDatabase p t)
searchDocInDatabase p t = runOpaQuery (queryDocInDatabase p t)
where
-- | Global search query where ParentId is Master Node Corpus Id
queryInDatabase :: ParentId -> Text -> O.Query (Column PGInt4, Column PGJsonb)
queryInDatabase _ q = proc () -> do
queryDocInDatabase :: ParentId -> Text -> O.Query (Column PGInt4, Column PGJsonb)
queryDocInDatabase _ q = proc () -> do
row <- queryNodeSearchTable -< ()
restrict -< (_ns_search row) @@ (pgTSQuery (unpack q))
restrict -< (_ns_typename row) .== (pgInt4 $ nodeTypeId NodeDocument)
......@@ -105,132 +106,97 @@ joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
cond (n, nn) = nn^.nn_node2_id .== _ns_id n
------------------------------------------------------------------------
type AuthorName = Text
-- | TODO Optim: Offset and Limit in the Query
-- TODO-SECURITY check
searchInCorpusWithContacts
:: CorpusId
-> ListId
-> [Text]
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Cmd err [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
searchInCorpusWithContacts cId lId q o l order =
take (maybe 10 identity l)
<$> drop (maybe 0 identity o)
<$> map (\((i,u,h,s), ps) -> FacetPaired i u h s ps)
<$> toList <$> fromListWith (<>)
<$> map (\(FacetPaired i u h s (p1,p2)) -> ( (i,u,h,s)
, catMaybes [Pair <$> p1 <*> p2]
)
)
<$> searchInCorpusWithContacts' cId lId q o l order
-- TODO-SECURITY check
searchInCorpusWithContacts'
:: CorpusId
-> ListId
-> AnnuaireId
-> [Text]
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Cmd err [(FacetPaired Int UTCTime HyperdataDocument Int (Maybe Int, Maybe Text))]
searchInCorpusWithContacts' cId lId q o l order =
runOpaQuery $ queryInCorpusWithContacts cId lId o l order
-> Cmd err [FacetPaired Int UTCTime HyperdataContact Int]
searchInCorpusWithContacts cId aId q o l _order =
runOpaQuery $ limit' l
$ offset' o
-- $ orderBy ( o l order
$ selectContactViaDoc cId aId
$ intercalate " | "
$ map stemIt q
queryInCorpusWithContacts
selectContactViaDoc
:: CorpusId
-> ListId
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> AnnuaireId
-> Text
-> O.Query FacetPairedRead
queryInCorpusWithContacts cId _lId _ _ _ q = proc () -> do
(n, (nn, (_nng, (ngrams', (_, contacts))))) <- joinInCorpusWithContacts -< ()
restrict -< (n^.ns_search) @@ (pgTSQuery $ unpack q )
restrict -< (n^.ns_typename) .== (pgInt4 $ nodeTypeId NodeDocument)
-- restrict -< (nng^.nnng_node1_id) .== (toNullable $ pgNodeId lId)
restrict -< (nn^.nn_node1_id) .== (toNullable $ pgNodeId cId)
-- -- restrict -< (nng_listType nng) .== (toNullable $ pgNgramsType Authors)
-- restrict -< (contacts^.node_typename) .== (toNullable $ pgInt4 $ nodeTypeId NodeContact)
-- -- let contact_id = ifThenElse (isNull $ _node_id contacts) (toNullable $ pgInt4 0) (_node_id contacts)
returnA -< FacetPaired (n^.ns_id)
(n^.ns_date)
(n^.ns_hyperdata)
(pgInt4 0)
(contacts^.node_id, ngrams'^.ngrams_terms)
joinInCorpusWithContacts :: O.Query ( NodeSearchRead
-> O.Query FacetPairedReadNull
selectContactViaDoc cId aId q = proc () -> do
(doc, (corpus_doc, (contact_doc, (annuaire_contact, contact)))) <- queryContactViaDoc -< ()
restrict -< (doc^.ns_search) @@ (pgTSQuery $ unpack q )
restrict -< (doc^.ns_typename) .== (pgInt4 $ nodeTypeId NodeDocument)
restrict -< (corpus_doc^.nn_node1_id) .== (toNullable $ pgNodeId cId)
restrict -< (annuaire_contact^.nn_node1_id) .== (toNullable $ pgNodeId aId)
restrict -< (contact^.node_typename) .== (toNullable $ pgInt4 $ nodeTypeId NodeContact)
returnA -< FacetPaired (contact^.node_id)
(contact^.node_date)
(contact^.node_hyperdata)
(toNullable $ pgInt4 0)
queryContactViaDoc :: O.Query ( NodeSearchRead
, ( NodeNodeReadNull
, ( NodeNodeReadNull
, ( NodeNodeReadNull
, ( NodeNodeNgramsReadNull
, ( NgramsReadNull
, ( NodeNodeNgramsReadNull
, NodeReadNull
)
)
)
)
)
joinInCorpusWithContacts =
leftJoin6
queryContactViaDoc =
leftJoin5
queryNodeTable
queryNodeNodeNgramsTable
queryNgramsTable
queryNodeNodeNgramsTable
queryNodeNodeTable
queryNodeNodeTable
queryNodeNodeTable
queryNodeSearchTable
cond12
cond23
cond34
cond45
cond56
where
cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
cond12 (nnng, n2) = n2^.node_id .== nnng^.nnng_node1_id
cond12 :: (NodeNodeRead, NodeRead) -> Column PGBool
cond12 (annuaire_contact, contact) = contact^.node_id .== annuaire_contact^.nn_node2_id
cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
cond23 (ng2, (nnng2, _)) = nnng2^.nnng_ngrams_id .== ng2^.ngrams_id
cond34 :: ( NodeNodeNgramsRead
, ( NgramsRead
, ( NodeNodeNgramsReadNull
cond23 :: ( NodeNodeRead
, ( NodeNodeRead
, NodeReadNull
)
)
) -> Column PGBool
cond34 (nng, (ng, (_,_))) = ng^.ngrams_id .== nng^.nnng_ngrams_id
cond23 (contact_doc, (annuaire_contact, _)) = contact_doc^.nn_node1_id .== annuaire_contact^.nn_node2_id
cond45 :: ( NodeNodeRead
, ( NodeNodeNgramsRead
, ( NgramsReadNull
, ( NodeNodeNgramsReadNull
cond34 :: ( NodeNodeRead
, ( NodeNodeRead
, ( NodeNodeReadNull
, NodeReadNull
)
)
)
) -> Column PGBool
cond45 (nn, (nng, (_,(_,_)))) = nng^.nnng_node1_id .== nn^.nn_node2_id
cond34 (corpus_doc, (contact_doc, (_,_))) = corpus_doc^.nn_node2_id .== contact_doc^.nn_node2_id
cond56 :: ( NodeSearchRead
cond45 :: ( NodeSearchRead
, ( NodeNodeRead
, ( NodeNodeNgramsReadNull
, ( NgramsReadNull
, ( NodeNodeNgramsReadNull
, ( NodeNodeReadNull
, ( NodeNodeReadNull
, NodeReadNull
)
)
)
)
) -> Column PGBool
cond56 (n, (nn, (_,(_,(_,_))))) = _ns_id n .== nn^.nn_node2_id
cond45 (doc, (corpus_doc, (_,(_,_)))) = doc^.ns_id .== corpus_doc^.nn_node2_id
------------------------------------------------------------------------
newtype TSQuery = UnsafeTSQuery [Text]
-- | TODO [""] -> panic "error"
......
src/Gargantext/Database/Action/Share.hs
View file @ 25f2808e
......@@ -14,6 +14,7 @@ module Gargantext.Database.Action.Share
where
import Control.Lens (view)
import Gargantext.Database
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.Flow.Utils (getUserId)
import Gargantext.Database.Admin.Config (hasNodeType, isInNodeTypes)
......@@ -45,7 +46,7 @@ data ShareNodeWith = ShareNodeWith_User { snwu_nodetype :: NodeType
shareNodeWith :: HasNodeError err
=> ShareNodeWith
-> NodeId
-> Cmd err Int64
-> Cmd err Int
shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
nodeToCheck <- getNode n
userIdCheck <- getUserId u
......@@ -56,7 +57,7 @@ shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
then errorWith "[G.D.A.S.shareNodeWith] Can share to others only"
else do
folderSharedId <- getFolderId u NodeFolderShared
insertNodeNode [NodeNode folderSharedId n Nothing Nothing]
insertDB ([NodeNode folderSharedId n Nothing Nothing]:: [NodeNode])
shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
nodeToCheck <- getNode n
......@@ -66,7 +67,7 @@ shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
else do
folderToCheck <- getNode nId
if hasNodeType folderToCheck NodeFolderPublic
then insertNodeNode [NodeNode nId n Nothing Nothing]
then insertDB ([NodeNode nId n Nothing Nothing] :: [NodeNode])
else errorWith "[G.D.A.S.shareNodeWith] Can share NodeWith NodeFolderPublic only"
shareNodeWith _ _ = errorWith "[G.D.A.S.shareNodeWith] Not implemented for this NodeType"
......
src/Gargantext/Database/Admin/Types/Hyperdata/Contact.hs
View file @ 25f2808e
......@@ -150,6 +150,12 @@ instance FromField HyperdataContact where
instance QueryRunnerColumnDefault PGJsonb HyperdataContact where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault (Nullable PGJsonb) HyperdataContact where
queryRunnerColumnDefault = fieldQueryRunnerColumn
-- | All lenses
makeLenses ''ContactWho
makeLenses ''ContactWhere
......
src/Gargantext/Database/Admin/Types/Hyperdata/Prelude.hs
View file @ 25f2808e
......@@ -48,7 +48,7 @@ import GHC.Generics (Generic)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
import Gargantext.Database.Prelude (fromField')
import Gargantext.Prelude
import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn)
import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn, Nullable)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
......
src/Gargantext/Database/Admin/Types/Node.hs
View file @ 25f2808e
......@@ -337,4 +337,7 @@ instance QueryRunnerColumnDefault (Nullable PGInt4) NodeId
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance (QueryRunnerColumnDefault (Nullable O.PGTimestamptz) UTCTime)
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
src/Gargantext/Database/Prelude.hs
View file @ 25f2808e
......@@ -45,7 +45,6 @@ import qualified Data.List as DL
import qualified Database.PostgreSQL.Simple as PGS
-------------------------------------------------------
class HasConnectionPool env where
connPool :: Getter env (Pool Connection)
......
src/Gargantext/Database/Query/Facet.hs
View file @ 25f2808e
......@@ -29,6 +29,7 @@ module Gargantext.Database.Query.Facet
, FacetDocRead
, FacetPaired(..)
, FacetPairedRead
, FacetPairedReadNull
, OrderBy(..)
)
where
......@@ -111,12 +112,11 @@ instance (Typeable i, Typeable l, ToSchema i, ToSchema l) => ToSchema (Pair i l)
instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
arbitrary = Pair <$> arbitrary <*> arbitrary
data FacetPaired id date hyperdata score pair =
data FacetPaired id date hyperdata score =
FacetPaired {_fp_id :: id
,_fp_date :: date
,_fp_hyperdata :: hyperdata
,_fp_score :: score
,_fp_pair :: pair
} deriving (Show, Generic)
$(deriveJSON (unPrefix "_fp_") ''FacetPaired)
$(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
......@@ -125,30 +125,31 @@ instance ( ToSchema id
, ToSchema date
, ToSchema hyperdata
, ToSchema score
, ToSchema pair
, Typeable id
, Typeable date
, Typeable hyperdata
, Typeable score
, Typeable pair
) => ToSchema (FacetPaired id date hyperdata score pair) where
) => ToSchema (FacetPaired id date hyperdata score) where
declareNamedSchema = wellNamedSchema "_fp_"
instance ( Arbitrary id
, Arbitrary date
, Arbitrary hyperdata
, Arbitrary score
, Arbitrary pair
) => Arbitrary (FacetPaired id date hyperdata score pair) where
arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
) => Arbitrary (FacetPaired id date hyperdata score) where
arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
type FacetPairedRead = FacetPaired (Column PGInt4 )
(Column PGTimestamptz)
(Column PGJsonb )
(Column PGInt4 )
( Column (Nullable PGInt4)
, Column (Nullable PGText)
)
type FacetPairedReadNull = FacetPaired (Column (Nullable PGInt4) )
(Column (Nullable PGTimestamptz))
(Column (Nullable PGJsonb) )
(Column (Nullable PGInt4) )
-- | JSON instance
$(deriveJSON (unPrefix "facetDoc_") ''Facet)
......
src/Gargantext/Database/Query/Table/NodeNode.hs
View file @ 25f2808e
......@@ -95,9 +95,9 @@ getNodeNodeWith pId _ maybeNodeType = runOpaQuery query
-}
------------------------------------------------------------------------
insertNodeNode :: [NodeNode] -> Cmd err Int64
insertNodeNode ns = mkCmd $ \conn -> runInsert_ conn
$ Insert nodeNodeTable ns' rCount Nothing
insertNodeNode :: [NodeNode] -> Cmd err Int
insertNodeNode ns = mkCmd $ \conn -> fromIntegral <$> (runInsert_ conn
$ Insert nodeNodeTable ns' rCount Nothing)
where
ns' :: [NodeNodeWrite]
ns' = map (\(NodeNode n1 n2 x y)
......@@ -107,6 +107,8 @@ insertNodeNode ns = mkCmd $ \conn -> runInsert_ conn
(pgInt4 <$> y)
) ns
------------------------------------------------------------------------
type Node1_Id = NodeId
type Node2_Id = NodeId
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment