Skip to content

haskell-gargantext
haskell-gargantext
Commit e08e94f9 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[PAIR][WIP] NodeNgrams -> NodeNodeNgrams, needs tests.

parent 8a83ba4e
Hide whitespace changes
Inline Side-by-side
Showing with 400 additions and 253 deletions
src/Gargantext/API.hs
View file @ e08e94f9
......@@ -266,7 +266,8 @@ type GargPrivateAPI' =
:> ReqBody '[JSON] Query :> CountAPI
-- Corpus endpoint --> TODO rename s/search/filter/g
:<|> "search":> Capture "corpus" NodeId :> SearchPairsAPI
:<|> "search":> Capture "corpus" NodeId
:> SearchPairsAPI
-- TODO move to NodeAPI?
:<|> "graph" :> Summary "Graph endpoint"
......
src/Gargantext/API/Node.hs
View file @ e08e94f9
......@@ -131,7 +131,7 @@ type NodeAPI a = Get '[JSON] (Node a)
-- TODO gather it
:<|> "table" :> TableApi
:<|> "ngrams" :> TableNgramsApi
:<|> "pairing" :> PairingApi
-- :<|> "pairing" :> PairingApi
:<|> "category" :> CatApi
:<|> "search" :> SearchDocsAPI
......@@ -187,7 +187,7 @@ nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode i
-- TODO gather it
:<|> tableApi id
:<|> apiNgramsTableCorpus id
:<|> getPairing id
-- :<|> getPairing id
-- :<|> getTableNgramsDoc id
:<|> catApi id
......
src/Gargantext/API/Search.hs
View file @ e08e94f9
......@@ -65,7 +65,8 @@ instance Arbitrary SearchDocResults where
instance ToSchema SearchDocResults where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "sdr_")
data SearchPairedResults = SearchPairedResults { spr_results :: [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]] }
data SearchPairedResults =
SearchPairedResults { spr_results :: [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]] }
deriving (Generic)
$(deriveJSON (unPrefix "spr_") ''SearchPairedResults)
......@@ -87,12 +88,14 @@ type SearchAPI results
:> Post '[JSON] results
type SearchDocsAPI = SearchAPI SearchDocResults
type SearchPairsAPI = SearchAPI SearchPairedResults
type SearchPairsAPI =
Summary "" :> "list" :> Capture "list" ListId
:> SearchAPI SearchPairedResults
-----------------------------------------------------------------------
searchPairs :: NodeId -> GargServer SearchPairsAPI
searchPairs pId (SearchQuery q) o l order =
SearchPairedResults <$> searchInCorpusWithContacts pId q o l order
searchPairs pId lId (SearchQuery q) o l order =
SearchPairedResults <$> searchInCorpusWithContacts pId lId q o l order
searchDocs :: NodeId -> GargServer SearchDocsAPI
searchDocs nId (SearchQuery q) o l order =
......
src/Gargantext/API/Table.hs
View file @ e08e94f9
......@@ -46,7 +46,7 @@ import GHC.Generics (Generic)
import Gargantext.API.Ngrams (TabType(..))
import Gargantext.Core.Types (Offset, Limit)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),runViewAuthorsDoc)
import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..))
import Gargantext.Database.Learn (FavOrTrash(..), moreLike)
import Gargantext.Database.TextSearch
import Gargantext.Database.Types.Node
......@@ -97,6 +97,7 @@ getTable cId ft o l order =
(Just MoreTrash) -> moreLike cId o l order IsTrash
x -> panic $ "not implemented in getTable: " <> (cs $ show x)
{-
getPairing :: ContactId -> Maybe TabType
-> Maybe Offset -> Maybe Limit
-> Maybe OrderBy -> Cmd err [FacetDoc]
......@@ -106,4 +107,4 @@ getPairing cId ft o l order =
(Just Trash) -> runViewAuthorsDoc cId True o l order
_ -> panic $ "not implemented: get Pairing" <> (cs $ show ft)
-}
src/Gargantext/Database/Facet.hs
View file @ e08e94f9
......@@ -26,8 +26,8 @@ Portability : POSIX
{-# LANGUAGE TypeFamilies #-}
------------------------------------------------------------------------
module Gargantext.Database.Facet
( runViewAuthorsDoc
, runViewDocuments
( -- runViewAuthorsDoc
runViewDocuments
, filterWith
, Pair(..)
......@@ -41,6 +41,7 @@ module Gargantext.Database.Facet
where
------------------------------------------------------------------------
import Control.Arrow (returnA)
import Control.Lens ((^.))
-- import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.TH (deriveJSON)
......@@ -57,7 +58,6 @@ import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.NodeNgram
import Gargantext.Database.Schema.NodeNode
import Gargantext.Database.Utils
import Gargantext.Database.Queries.Join
......@@ -115,36 +115,39 @@ instance (ToSchema i, ToSchema l) => ToSchema (Pair i l) where
instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
arbitrary = Pair <$> arbitrary <*> arbitrary
data FacetPaired id date hyperdata score pairs =
data FacetPaired id date hyperdata score pair =
FacetPaired {_fp_id :: id
,_fp_date :: date
,_fp_hyperdata :: hyperdata
,_fp_score :: score
,_fp_pairs :: pairs
,_fp_pair :: pair
} deriving (Show, Generic)
$(deriveJSON (unPrefix "_fp_") ''FacetPaired)
$(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
instance (ToSchema id, ToSchema date, ToSchema hyperdata, ToSchema pairs, ToSchema score) => ToSchema (FacetPaired id date hyperdata score pairs) where
instance ( ToSchema id
, ToSchema date
, ToSchema hyperdata
, ToSchema score
, ToSchema pair
) => ToSchema (FacetPaired id date hyperdata score pair) where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fp_")
instance ( Arbitrary id
, Arbitrary date
, Arbitrary hyperdata
, Arbitrary score
, Arbitrary pairs
) => Arbitrary (FacetPaired id date hyperdata score pairs) where
, Arbitrary pair
) => Arbitrary (FacetPaired id date hyperdata score pair) where
arbitrary = FacetPaired <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
--{-
type FacetPairedRead = FacetPaired (Column PGInt4 )
(Column PGTimestamptz)
(Column PGJsonb )
(Column PGInt4 )
(Pair (Column (Nullable PGInt4)) (Column (Nullable PGText)))
--}
( Column (Nullable PGInt4)
, Column (Nullable PGText)
)
-- | JSON instance
$(deriveJSON (unPrefix "facetDoc_") ''Facet)
......@@ -206,6 +209,8 @@ instance Arbitrary OrderBy
-- TODO-SECURITY check
{-
runViewAuthorsDoc :: ContactId -> IsTrash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
where
......@@ -234,16 +239,16 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable
.== nng_node_id nodeNgram
cond23 :: (NgramsRead, (NodeNgramRead, NodeReadNull)) -> Column PGBool
cond23 (ngrams, (nodeNgram, _)) = ngrams_id ngrams
cond23 (ngrams, (nodeNgram, _)) = ngrams^.ngrams_id
.== nng_ngrams_id nodeNgram
cond34 :: (NodeNgramRead, (NgramsRead, (NodeNgramReadNull, NodeReadNull))) -> Column PGBool
cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams_id ngrams .== nng_ngrams_id nodeNgram2
cond34 (nodeNgram2, (ngrams, (_,_)))= ngrams^.ngrams_id .== nng_ngrams_id nodeNgram2
cond45 :: (NodeRead, (NodeNgramRead, (NgramsReadNull, (NodeNgramReadNull, NodeReadNull)))) -> Column PGBool
cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id contact .== nng_node_id nodeNgram2
-}
------------------------------------------------------------------------
-- TODO-SECURITY check
......@@ -257,12 +262,12 @@ viewDocuments :: CorpusId -> IsTrash -> NodeTypeId -> Query FacetDocRead
viewDocuments cId t ntId = proc () -> do
n <- queryNodeTable -< ()
nn <- queryNodeNodeTable -< ()
restrict -< _node_id n .== nn_node2_id nn
restrict -< nn_node1_id nn .== (pgNodeId cId)
restrict -< _node_typename n .== (pgInt4 ntId)
restrict -< if t then nn_category nn .== (pgInt4 0)
else nn_category nn .>= (pgInt4 1)
returnA -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (toNullable $ nn_category nn) (toNullable $ nn_score nn)
restrict -< n^.node_id .== nn^.nn_node2_id
restrict -< nn^.nn_node1_id .== (pgNodeId cId)
restrict -< n^.node_typename .== (pgInt4 ntId)
restrict -< if t then nn^.nn_category .== (pgInt4 0)
else nn^.nn_category .>= (pgInt4 1)
returnA -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (toNullable $ nn^.nn_category) (toNullable $ nn^.nn_score)
------------------------------------------------------------------------
......
src/Gargantext/Database/Flow.hs
View file @ e08e94f9
......@@ -7,15 +7,12 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-- TODO-ACCESS:
-- check userId CanFillUserCorpus userCorpusId
-- check masterUserId CanFillMasterCorpus masterCorpusId
-- TODO-ACCESS: check uId CanInsertDoc pId && checkDocType nodeType
-- TODO-EVENTS: InsertedNodes
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
......@@ -109,29 +106,32 @@ getDataApi lang limit (ApiIsidoreAuth q) = Isidore.get lang limit Nothing (Jus
-- UNUSED
_flowCorpusApi :: ( FlowCmdM env err m)
=> Username -> Either CorpusName [CorpusId]
-> TermType Lang
-> Maybe Limit
-> ApiQuery
-> m CorpusId
=> Username -> Either CorpusName [CorpusId]
-> TermType Lang
-> Maybe Limit
-> ApiQuery
-> m CorpusId
_flowCorpusApi u n tt l q = do
docs <- liftIO $ splitEvery 500 <$> getDataApi (_tt_lang tt) l q
flowCorpus u n tt docs
------------------------------------------------------------------------
-- UNUSED
flowAnnuaire :: FlowCmdM env err m
=> Username -> Either CorpusName [CorpusId] -> (TermType Lang) -> FilePath -> m AnnuaireId
=> Username
-> Either CorpusName [CorpusId]
-> (TermType Lang)
-> FilePath
-> m AnnuaireId
flowAnnuaire u n l filePath = do
docs <- liftIO $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
-- UNUSED
_flowCorpusDebat :: FlowCmdM env err m
=> Username -> Either CorpusName [CorpusId]
-> Limit -> FilePath
-> m CorpusId
=> Username -> Either CorpusName [CorpusId]
-> Limit -> FilePath
-> m CorpusId
_flowCorpusDebat u n l fp = do
docs <- liftIO ( splitEvery 500
<$> take l
......@@ -154,18 +154,30 @@ flowCorpusFile u n l la ff fp = do
-- TODO query with complex query
flowCorpusSearchInDatabase :: FlowCmdM env err m
=> Username -> Lang -> Text -> m CorpusId
=> Username
-> Lang
-> Text
-> m CorpusId
flowCorpusSearchInDatabase u la q = do
(_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster (Left "") (Nothing :: Maybe HyperdataCorpus)
(_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus
userMaster
(Left "")
(Nothing :: Maybe HyperdataCorpus)
ids <- map fst <$> searchInDatabase cId (stemIt q)
flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
-- UNUSED
_flowCorpusSearchInDatabaseApi :: FlowCmdM env err m
=> Username -> Lang -> Text -> m CorpusId
=> Username
-> Lang
-> Text
-> m CorpusId
_flowCorpusSearchInDatabaseApi u la q = do
(_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster (Left "") (Nothing :: Maybe HyperdataCorpus)
(_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus
userMaster
(Left "")
(Nothing :: Maybe HyperdataCorpus)
ids <- map fst <$> searchInDatabase cId (stemIt q)
flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
......@@ -178,20 +190,33 @@ data CorpusInfo = CorpusName Lang Text
| CorpusId Lang NodeId
-}
flow :: (FlowCmdM env err m, FlowCorpus a, MkCorpus c)
=> Maybe c -> Username -> Either CorpusName [CorpusId] -> TermType Lang -> [[a]] -> m CorpusId
=> Maybe c
-> Username
-> Either CorpusName [CorpusId]
-> TermType Lang
-> [[a]]
-> m CorpusId
flow c u cn la docs = do
ids <- mapM (insertMasterDocs c la ) docs
flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
=> Username -> Either CorpusName [CorpusId] -> TermType Lang -> [[a]] -> m CorpusId
=> Username
-> Either CorpusName [CorpusId]
-> TermType Lang
-> [[a]]
-> m CorpusId
flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
------------------------------------------------------------------------
flowCorpusUser :: (FlowCmdM env err m, MkCorpus c)
=> Lang -> Username -> Either CorpusName [CorpusId] -> Maybe c -> [NodeId] -> m CorpusId
=> Lang
-> Username
-> Either CorpusName [CorpusId]
-> Maybe c
-> [NodeId]
-> m CorpusId
flowCorpusUser l userName corpusName ctype ids = do
-- User Flow
(userId, _rootId, userCorpusId) <- getOrMkRootWithCorpus userName corpusName ctype
......@@ -223,7 +248,10 @@ insertMasterDocs :: ( FlowCmdM env err m
, FlowCorpus a
, MkCorpus c
)
=> Maybe c -> TermType Lang -> [a] -> m [DocId]
=> Maybe c
-> TermType Lang
-> [a]
-> m [DocId]
insertMasterDocs c lang hs = do
(masterUserId, _, masterCorpusId) <- getOrMkRootWithCorpus userMaster (Left corpusMasterName) c
......@@ -231,8 +259,8 @@ insertMasterDocs c lang hs = do
let hs' = map addUniqId hs
ids <- insertDb masterUserId masterCorpusId hs'
let documentsWithId = mergeData (toInserted ids) (Map.fromList $ map viewUniqId' hs')
let
let
fixLang (Unsupervised l n s m) = Unsupervised l n s m'
where
m' = case m of
......@@ -251,16 +279,19 @@ insertMasterDocs c lang hs = do
maps <- mapNodeIdNgrams <$> documentIdWithNgrams (extractNgramsT lang') documentsWithId
terms2id <- insertNgrams $ Map.keys maps
let indexedNgrams = Map.mapKeys (indexNgrams terms2id) maps
lId <- getOrMkList masterCorpusId masterUserId
_ <- insertDocNgrams lId indexedNgrams
pure $ map reId ids
type CorpusName = Text
getOrMkRoot :: (HasNodeError err) => Username -> Cmd err (UserId, RootId)
getOrMkRoot :: (HasNodeError err)
=> Username
-> Cmd err (UserId, RootId)
getOrMkRoot username = do
maybeUserId <- getUser username
userId <- case maybeUserId of
......@@ -280,8 +311,10 @@ getOrMkRoot username = do
getOrMkRootWithCorpus :: (HasNodeError err, MkCorpus a)
=> Username -> Either CorpusName [CorpusId] -> Maybe a
-> Cmd err (UserId, RootId, CorpusId)
=> Username
-> Either CorpusName [CorpusId]
-> Maybe a
-> Cmd err (UserId, RootId, CorpusId)
getOrMkRootWithCorpus username cName c = do
(userId, rootId) <- getOrMkRoot username
corpusId'' <- if username == userMaster
......@@ -301,15 +334,19 @@ getOrMkRootWithCorpus username cName c = do
------------------------------------------------------------------------
viewUniqId' :: UniqId a => a -> (HashId, a)
viewUniqId' :: UniqId a
=> a
-> (HashId, a)
viewUniqId' d = maybe err (\h -> (h,d)) (view uniqId d)
where
err = panic "[ERROR] Database.Flow.toInsert"
toInserted :: [ReturnId] -> Map HashId ReturnId
toInserted = Map.fromList . map (\r -> (reUniqId r, r) )
. filter (\r -> reInserted r == True)
toInserted :: [ReturnId]
-> Map HashId ReturnId
toInserted =
Map.fromList . map (\r -> (reUniqId r, r) )
. filter (\r -> reInserted r == True)
data DocumentWithId a = DocumentWithId
{ documentId :: !NodeId
......@@ -361,34 +398,36 @@ instance HasText HyperdataDocument
instance ExtractNgramsT HyperdataDocument
where
extractNgramsT :: TermType Lang -> HyperdataDocument -> Cmd err (Map Ngrams (Map NgramsType Int))
extractNgramsT :: TermType Lang
-> HyperdataDocument
-> Cmd err (Map Ngrams (Map NgramsType Int))
extractNgramsT lang hd = filterNgramsT 255 <$> extractNgramsT' lang hd
where
extractNgramsT' :: TermType Lang -> HyperdataDocument
extractNgramsT' :: TermType Lang
-> HyperdataDocument
-> Cmd err (Map Ngrams (Map NgramsType Int))
extractNgramsT' lang' doc = do
let source = text2ngrams
$ maybe "Nothing" identity
$ _hyperdataDocument_source doc
institutes = map text2ngrams
$ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))
$ _hyperdataDocument_institutes doc
authors = map text2ngrams
$ maybe ["Nothing"] (splitOn ", ")
$ _hyperdataDocument_authors doc
terms' <- map text2ngrams
<$> map (intercalate " " . _terms_label)
<$> concat
<$> liftIO (extractTerms lang' $ hasText doc)
pure $ Map.fromList $ [(source, Map.singleton Sources 1)]
<> [(i', Map.singleton Institutes 1) | i' <- institutes ]
<> [(a', Map.singleton Authors 1) | a' <- authors ]
<> [(t', Map.singleton NgramsTerms 1) | t' <- terms' ]
filterNgramsT :: Int -> Map Ngrams (Map NgramsType Int)
-> Map Ngrams (Map NgramsType Int)
......@@ -425,13 +464,16 @@ mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
------------------------------------------------------------------------
listInsert :: FlowCmdM env err m
=> ListId -> Map NgramsType [NgramsElement]
=> ListId
-> Map NgramsType [NgramsElement]
-> m ()
listInsert lId ngs = mapM_ (\(typeList, ngElmts)
-> putListNgrams lId typeList ngElmts
) $ toList ngs
flowList :: FlowCmdM env err m => UserId -> CorpusId
flowList :: FlowCmdM env err m
=> UserId
-> CorpusId
-> Map NgramsType [NgramsElement]
-> m ListId
flowList uId cId ngs = do
......
src/Gargantext/Database/Flow/Pairing.hs
View file @ e08e94f9
......@@ -33,21 +33,22 @@ import Data.Text (Text, toLower)
import qualified Data.Text as DT
import Gargantext.Prelude hiding (sum)
import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
--import Gargantext.Database.Node.Contact -- (HyperdataContact(..))
--import Gargantext.Database.Types.Node -- (Hyperdata(..))
import Gargantext.Database.Node.Contact
import Gargantext.Database.Node.Contact -- (HyperdataContact(..))
import Gargantext.Database.Flow.Utils
import Gargantext.Database.Utils (Cmd, runPGSQuery)
import Gargantext.Database.Types.Node (AnnuaireId, CorpusId)
import Gargantext.Database.Node.Children
import Gargantext.Database.Types.Node (AnnuaireId, CorpusId, ListId)
import Gargantext.Database.Node.Children (getContacts)
import Gargantext.Core.Types (NodeType(..))
-- TODO mv this type in Types Main
type Terms = Text
-- | TODO : add paring policy as parameter
pairing :: AnnuaireId -> CorpusId -> Cmd err Int
pairing aId cId = do
pairing :: AnnuaireId
-> CorpusId
-> ListId
-> Cmd err Int
pairing aId cId lId = do
contacts' <- getContacts aId (Just NodeContact)
let contactsMap = pairingPolicyToMap toLower $ toMaps extractNgramsT contacts'
......@@ -56,31 +57,34 @@ pairing aId cId = do
let indexedNgrams = pairMaps contactsMap ngramsMap
insertToNodeNgrams indexedNgrams
-- TODO add List
insertDocNgrams lId indexedNgrams
lastName :: Terms -> Terms
lastName texte = DT.toLower $ maybe texte (\x -> if DT.length x > 3 then x else texte) (lastName' texte)
lastName texte = DT.toLower
$ maybe texte (\x -> if DT.length x > 3 then x else texte) (lastName' texte)
where
lastName' = lastMay . DT.splitOn " "
-- TODO: this methods is dangerous (maybe equalities of the result are not taken into account
-- emergency demo plan...
-- TODO: this method is dangerous (maybe equalities of the result are not taken into account
-- emergency demo plan...)
pairingPolicyToMap :: (Terms -> Terms)
-> Map (NgramsT Ngrams) a -> Map (NgramsT Ngrams) a
-> Map (NgramsT Ngrams) a
-> Map (NgramsT Ngrams) a
pairingPolicyToMap f = DM.mapKeys (pairingPolicy f)
pairingPolicy :: (Terms -> Terms) -> NgramsT Ngrams -> NgramsT Ngrams
pairingPolicy :: (Terms -> Terms)
-> NgramsT Ngrams
-> NgramsT Ngrams
pairingPolicy f (NgramsT nt (Ngrams ng _)) = (NgramsT nt (Ngrams (f ng) 1))
-- | TODO : use Occurrences in place of Int
extractNgramsT :: HyperdataContact -> Map (NgramsT Ngrams) Int
extractNgramsT :: HyperdataContact
-> Map (NgramsT Ngrams) Int
extractNgramsT contact = fromList [(NgramsT Authors a' , 1)| a' <- authors ]
where
authors = map text2ngrams $ catMaybes [view (hc_who . _Just . cw_lastName) contact]
--}
-- NP: notice how this function is no longer specific to the ContactId type
pairMaps :: Map (NgramsT Ngrams) a
-> Map (NgramsT Ngrams) NgramsId
-> Map NgramsIndexed (Map NgramsType a)
......@@ -92,23 +96,27 @@ pairMaps m1 m2 =
]
-----------------------------------------------------------------------
getNgramsTindexed:: CorpusId -> NgramsType -> Cmd err (Map (NgramsT Ngrams) NgramsId)
getNgramsTindexed :: CorpusId
-> NgramsType
-> Cmd err (Map (NgramsT Ngrams) NgramsId)
getNgramsTindexed corpusId ngramsType' = fromList
<$> map (\(ngramsId',t,n) -> (NgramsT ngramsType' (Ngrams t n),ngramsId'))
<$> selectNgramsTindexed corpusId ngramsType'
selectNgramsTindexed :: CorpusId -> NgramsType -> Cmd err [(NgramsId, Terms, Int)]
selectNgramsTindexed corpusId ngramsType'' = runPGSQuery selectQuery (corpusId, ngramsTypeId ngramsType'')
where
selectQuery = [sql| SELECT n.id,n.terms,n.n from ngrams n
JOIN nodes_ngrams occ ON occ.ngram_id = n.id
JOIN nodes_nodes nn ON nn.node2_id = occ.node_id
WHERE nn.node1_id = ?
AND occ.ngrams_type = ?
AND occ.node_id = nn.node2_id
GROUP BY n.id;
|]
selectNgramsTindexed :: CorpusId
-> NgramsType
-> Cmd err [(NgramsId, Terms, Int)]
selectNgramsTindexed corpusId' ngramsType'' = runPGSQuery selectQuery (corpusId', ngramsTypeId ngramsType'')
where
selectQuery = [sql| SELECT n.id,n.terms,n.n from ngrams n
JOIN node_node_ngrams occ ON occ.ngrams_id = n.id
JOIN nodes_nodes nn ON nn.node2_id = occ.node2_id
WHERE nn.node1_id = ?
AND occ.ngrams_type = ?
AND occ.node2_id = nn.node2_id
GROUP BY n.id;
|]
{- | TODO more typed SQL queries
selectNgramsTindexed :: CorpusId -> NgramsType -> Query NgramsRead
......@@ -124,5 +132,3 @@ selectNgramsTindexed corpusId ngramsType = proc () -> do
result <- aggregate groupBy (ngrams_id ngrams)
returnA -< result
--}
src/Gargantext/Database/Flow/Utils.hs
View file @ e08e94f9
......@@ -22,10 +22,8 @@ import Gargantext.Prelude
import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Types.Node (NodeId, Node, NodePoly(..), Hyperdata)
import Gargantext.Database.Utils (Cmd)
import Gargantext.Database.Schema.NodeNgram
import Gargantext.Database.Schema.NodeNodeNgrams
import Gargantext.Database.Types.Node
import Gargantext.Core.Types.Main (ListType(..), listTypeId)
toMaps :: Hyperdata a => (a -> Map (NgramsT Ngrams) Int) -> [Node a] -> Map (NgramsT Ngrams) (Map NodeId Int)
toMaps fun ns = mapNodeIdNgrams $ documentIdWithNgrams fun ns'
......@@ -39,8 +37,10 @@ mapNodeIdNgrams ds = DM.map (DM.fromListWith (+)) $ DM.fromListWith (<>) xs
n2i = map (\d -> ((documentId . documentWithId) d, document_ngrams d))
documentIdWithNgrams :: Hyperdata a => (a -> Map (NgramsT Ngrams) Int)
-> [DocumentWithId a] -> [DocumentIdWithNgrams a]
documentIdWithNgrams :: Hyperdata a
=> (a -> Map (NgramsT Ngrams) Int)
-> [DocumentWithId a]
-> [DocumentIdWithNgrams a]
documentIdWithNgrams f = map (\d -> DocumentIdWithNgrams d ((f . documentData) d))
......@@ -56,19 +56,12 @@ data DocumentIdWithNgrams a =
, document_ngrams :: Map (NgramsT Ngrams) Int
} deriving (Show)
-- | TODO for now, list Type is CandidateTerm because Graph Terms
-- have to be detected in next step in the flow
-- TODO remvoe this
insertToNodeNgrams :: Map NgramsIndexed (Map NgramsType (Map NodeId Int)) -> Cmd err Int
insertToNodeNgrams m = insertNodeNgrams [ NodeNgram n (_ngramsId ng) Nothing (ngramsTypeId t) (listTypeId CandidateTerm) (fromIntegral i)
| (ng, t2n2i) <- DM.toList m
, (t, n2i) <- DM.toList t2n2i
, (n, i) <- DM.toList n2i
]
docNgrams2nodeNodeNgrams :: CorpusId -> DocNgrams -> NodeNodeNgrams
docNgrams2nodeNodeNgrams cId (DocNgrams d n nt w) = NodeNodeNgrams Nothing cId d n nt w
docNgrams2nodeNodeNgrams :: CorpusId
-> DocNgrams
-> NodeNodeNgrams
docNgrams2nodeNodeNgrams cId (DocNgrams d n nt w) =
NodeNodeNgrams Nothing cId d n nt w
data DocNgrams = DocNgrams { dn_doc_id :: DocId
, dn_ngrams_id :: Int
......@@ -76,10 +69,14 @@ data DocNgrams = DocNgrams { dn_doc_id :: DocId
, dn_weight :: Double
}
insertDocNgramsOn :: CorpusId -> [DocNgrams] -> Cmd err Int
insertDocNgramsOn :: CorpusId
-> [DocNgrams]
-> Cmd err Int
insertDocNgramsOn cId dn = insertNodeNodeNgrams $ (map (docNgrams2nodeNodeNgrams cId) dn)
insertDocNgrams :: CorpusId -> Map NgramsIndexed (Map NgramsType (Map NodeId Int)) -> Cmd err Int
insertDocNgrams :: CorpusId
-> Map NgramsIndexed (Map NgramsType (Map NodeId Int))
-> Cmd err Int
insertDocNgrams cId m = insertDocNgramsOn cId [ DocNgrams n (_ngramsId ng) (ngramsTypeId t) (fromIntegral i)
| (ng, t2n2i) <- DM.toList m
, (t, n2i) <- DM.toList t2n2i
......
src/Gargantext/Database/Ngrams.hs
View file @ e08e94f9
......@@ -18,6 +18,7 @@ module Gargantext.Database.Ngrams
where
import Data.Text (Text)
import Control.Lens ((^.))
import Gargantext.Core.Types
import Gargantext.Database.Utils (runOpaQuery, Cmd)
import Gargantext.Database.Schema.Ngrams
......@@ -34,14 +35,14 @@ selectNgramsByDoc cIds dId nt = runOpaQuery (query cIds dId nt)
join :: Query (NgramsRead, NodeNodeNgramsReadNull)
join = leftJoin queryNgramsTable queryNodeNodeNgramsTable on1
where
on1 (ng,nnng) = ngrams_id ng .== nnng_ngrams_id nnng
on1 (ng,nnng) = ng^.ngrams_id .== nnng^.nnng_ngrams_id
query cIds' dId' nt' = proc () -> do
(ng,nnng) <- join -< ()
restrict -< foldl (\b cId -> ((toNullable $ pgNodeId cId) .== nnng_node1_id nnng) .|| b) (pgBool True) cIds'
restrict -< (toNullable $ pgNodeId dId') .== nnng_node2_id nnng
restrict -< (toNullable $ pgNgramsType nt') .== nnng_ngramsType nnng
returnA -< ngrams_terms ng
restrict -< foldl (\b cId -> ((toNullable $ pgNodeId cId) .== nnng^.nnng_node1_id) .|| b) (pgBool True) cIds'
restrict -< (toNullable $ pgNodeId dId') .== nnng^.nnng_node2_id
restrict -< (toNullable $ pgNgramsType nt') .== nnng^.nnng_ngramsType
returnA -< ng^.ngrams_terms
postNgrams :: CorpusId -> DocId -> [Text] -> Cmd err Int
......
src/Gargantext/Database/Node/Children.hs
View file @ e08e94f9
......@@ -30,24 +30,34 @@ import Gargantext.Database.Schema.Node (pgNodeId)
import Control.Arrow (returnA)
-- | TODO: use getChildren with Proxy ?
getContacts :: ParentId -> Maybe NodeType -> Cmd err [Node HyperdataContact]
getContacts :: ParentId
-> Maybe NodeType
-> Cmd err [Node HyperdataContact]
getContacts pId maybeNodeType = runOpaQuery $ selectChildren pId maybeNodeType
getChildren :: JSONB a => ParentId -> proxy a -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
getChildren :: JSONB a
=> ParentId
-> proxy a
-> Maybe NodeType
-> Maybe Offset
-> Maybe Limit
-> Cmd err [Node a]
getChildren pId _ maybeNodeType maybeOffset maybeLimit = runOpaQuery
$ limit' maybeLimit $ offset' maybeOffset
$ orderBy (asc _node_id)
$ selectChildren pId maybeNodeType
selectChildren :: ParentId -> Maybe NodeType -> Query NodeRead
selectChildren :: ParentId
-> Maybe NodeType
-> Query NodeRead
selectChildren parentId maybeNodeType = proc () -> do
row@(Node nId typeName _ parent_id _ _ _) <- queryNodeTable -< ()
(NodeNode n1id n2id _ _) <- queryNodeNodeTable -< ()
let nodeType = maybe 0 nodeTypeId maybeNodeType
restrict -< typeName .== pgInt4 nodeType
restrict -< (.||) (parent_id .== (pgNodeId parentId))
( (.&&) (n1id .== pgNodeId parentId)
(n2id .== nId))
......
src/Gargantext/Database/Node/Document/Insert.hs
View file @ e08e94f9
......@@ -186,7 +186,7 @@ queryInsert = [sql|
data ReturnId = ReturnId { reInserted :: Bool -- if the document is inserted (True: is new, False: is not new)
, reId :: NodeId -- always return the id of the document (even new or not new)
-- this is the uniq id in the database
, reUniqId :: Text -- Hash Id with concatenation of hash parameters
, reUniqId :: Text -- Hash Id with concatenation of sha parameters
} deriving (Show, Generic)
instance FromRow ReturnId where
......@@ -204,14 +204,14 @@ instance AddUniqId HyperdataDocument
addUniqId = addUniqIdsDoc
where
addUniqIdsDoc :: HyperdataDocument -> HyperdataDocument
addUniqIdsDoc doc = set hyperdataDocument_uniqIdBdd (Just hashBdd)
$ set hyperdataDocument_uniqId (Just hashUni) doc
addUniqIdsDoc doc = set hyperdataDocument_uniqIdBdd (Just shaBdd)
$ set hyperdataDocument_uniqId (Just shaUni) doc
where
hashUni = hash $ DT.concat $ map ($ doc) hashParametersDoc
hashBdd = hash $ DT.concat $ map ($ doc) ([(\d -> maybeText (_hyperdataDocument_bdd d))] <> hashParametersDoc)
shaUni = sha $ DT.concat $ map ($ doc) shaParametersDoc
shaBdd = sha $ DT.concat $ map ($ doc) ([(\d -> maybeText (_hyperdataDocument_bdd d))] <> shaParametersDoc)
hashParametersDoc :: [(HyperdataDocument -> Text)]
hashParametersDoc = [ \d -> maybeText (_hyperdataDocument_title d)
shaParametersDoc :: [(HyperdataDocument -> Text)]
shaParametersDoc = [ \d -> maybeText (_hyperdataDocument_title d)
, \d -> maybeText (_hyperdataDocument_abstract d)
, \d -> maybeText (_hyperdataDocument_source d)
, \d -> maybeText (_hyperdataDocument_publication_date d)
......@@ -226,18 +226,18 @@ instance AddUniqId HyperdataContact
addUniqId = addUniqIdsContact
addUniqIdsContact :: HyperdataContact -> HyperdataContact
addUniqIdsContact hc = set (hc_uniqIdBdd) (Just hashBdd)
$ set (hc_uniqId ) (Just hashUni) hc
addUniqIdsContact hc = set (hc_uniqIdBdd) (Just shaBdd)
$ set (hc_uniqId ) (Just shaUni) hc
where
hashUni = uniqId $ DT.concat $ map ($ hc) hashParametersContact
hashBdd = uniqId $ DT.concat $ map ($ hc) ([\d -> maybeText (view hc_bdd d)] <> hashParametersContact)
shaUni = uniqId $ DT.concat $ map ($ hc) shaParametersContact
shaBdd = uniqId $ DT.concat $ map ($ hc) ([\d -> maybeText (view hc_bdd d)] <> shaParametersContact)
uniqId :: Text -> Text
uniqId = DT.pack . SHA.showDigest . SHA.sha256 . DC.pack . DT.unpack
-- | TODO add more hashparameters
hashParametersContact :: [(HyperdataContact -> Text)]
hashParametersContact = [ \d -> maybeText $ view (hc_who . _Just . cw_firstName) d
-- | TODO add more shaparameters
shaParametersContact :: [(HyperdataContact -> Text)]
shaParametersContact = [ \d -> maybeText $ view (hc_who . _Just . cw_firstName) d
, \d -> maybeText $ view (hc_who . _Just . cw_lastName ) d
, \d -> maybeText $ view (hc_where . _head . cw_touch . _Just . ct_mail) d
]
......
src/Gargantext/Database/Schema/Ngrams.hs
View file @ e08e94f9
......@@ -51,9 +51,9 @@ type NgramsId = Int
type NgramsTerms = Text
type Size = Int
data NgramsPoly id terms n = NgramsDb { ngrams_id :: id
, ngrams_terms :: terms
, ngrams_n :: n
data NgramsPoly id terms n = NgramsDb { _ngrams_id :: id
, _ngrams_terms :: terms
, _ngrams_n :: n
} deriving (Show)
type NgramsWrite = NgramsPoly (Maybe (Column PGInt4))
......@@ -71,12 +71,13 @@ type NgramsReadNull = NgramsPoly (Column (Nullable PGInt4))
type NgramsDb = NgramsPoly Int Text Int
$(makeAdaptorAndInstance "pNgramsDb" ''NgramsPoly)
-- $(makeLensesWith abbreviatedFields ''NgramsPoly)
makeLenses ''NgramsPoly
ngramsTable :: Table NgramsWrite NgramsRead
ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { ngrams_id = optional "id"
, ngrams_terms = required "terms"
, ngrams_n = required "n"
ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { _ngrams_id = optional "id"
, _ngrams_terms = required "terms"
, _ngrams_n = required "n"
}
)
......
src/Gargantext/Database/Schema/Node.hs
View file @ e08e94f9
......@@ -699,6 +699,7 @@ mkNode nt p u = insertNodesR [nodeDefault nt p u]
mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
where
......@@ -709,7 +710,6 @@ mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
dashboard = maybe arbitraryDashboard identity maybeDashboard
mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
......@@ -718,8 +718,5 @@ mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
pgNodeId :: NodeId -> Column PGInt4
pgNodeId = pgInt4 . id2int
getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
src/Gargantext/Database/Schema/NodeNode.hs
View file @ e08e94f9
......@@ -25,11 +25,11 @@ commentary with @some markup@.
module Gargantext.Database.Schema.NodeNode where
import Control.Lens (view)
import Control.Lens (view, (^.))
import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Control.Lens.TH (makeLenses, makeLensesWith, abbreviatedFields)
import Data.Maybe (Maybe, catMaybes)
import Data.Text (Text, splitOn)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
......@@ -44,10 +44,10 @@ import Control.Arrow (returnA)
import qualified Opaleye as O
data NodeNodePoly node1_id node2_id score cat
= NodeNode { nn_node1_id :: node1_id
, nn_node2_id :: node2_id
, nn_score :: score
, nn_category :: cat
= NodeNode { _nn_node1_id :: node1_id
, _nn_node2_id :: node2_id
, _nn_score :: score
, _nn_category :: cat
} deriving (Show)
type NodeNodeWrite = NodeNodePoly (Column (PGInt4))
......@@ -59,7 +59,7 @@ type NodeNodeRead = NodeNodePoly (Column (PGInt4))
(Column (PGInt4))
(Column (PGFloat8))
(Column (PGInt4))
type NodeNodeReadNull = NodeNodePoly (Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGFloat8))
......@@ -68,14 +68,14 @@ type NodeNodeReadNull = NodeNodePoly (Column (Nullable PGInt4))
type NodeNode = NodeNodePoly Int Int (Maybe Double) (Maybe Int)
$(makeAdaptorAndInstance "pNodeNode" ''NodeNodePoly)
$(makeLensesWith abbreviatedFields ''NodeNodePoly)
makeLenses ''NodeNodePoly
nodeNodeTable :: Table NodeNodeWrite NodeNodeRead
nodeNodeTable = Table "nodes_nodes" (pNodeNode
NodeNode { nn_node1_id = required "node1_id"
, nn_node2_id = required "node2_id"
, nn_score = optional "score"
, nn_category = optional "category"
NodeNode { _nn_node1_id = required "node1_id"
, _nn_node2_id = required "node2_id"
, _nn_score = optional "score"
, _nn_category = optional "category"
}
)
......@@ -144,9 +144,9 @@ selectDocs cId = runOpaQuery (queryDocs cId)
queryDocs :: CorpusId -> O.Query (Column PGJsonb)
queryDocs cId = proc () -> do
(n, nn) <- joinInCorpus -< ()
restrict -< ( nn_node1_id nn) .== (toNullable $ pgNodeId cId)
restrict -< ( nn_category nn) .>= (toNullable $ pgInt4 1)
restrict -< (_node_typename n) .== (pgInt4 $ nodeTypeId NodeDocument)
restrict -< nn^.nn_node1_id .== (toNullable $ pgNodeId cId)
restrict -< nn^.nn_category .>= (toNullable $ pgInt4 1)
restrict -< n^.node_typename .== (pgInt4 $ nodeTypeId NodeDocument)
returnA -< view (node_hyperdata) n
......@@ -156,9 +156,9 @@ selectDocNodes cId = runOpaQuery (queryDocNodes cId)
queryDocNodes :: CorpusId -> O.Query NodeRead
queryDocNodes cId = proc () -> do
(n, nn) <- joinInCorpus -< ()
restrict -< ( nn_node1_id nn) .== (toNullable $ pgNodeId cId)
restrict -< ( nn_category nn) .>= (toNullable $ pgInt4 1)
restrict -< (_node_typename n) .== (pgInt4 $ nodeTypeId NodeDocument)
restrict -< nn^.nn_node1_id .== (toNullable $ pgNodeId cId)
restrict -< nn^.nn_category .>= (toNullable $ pgInt4 1)
restrict -< n^.node_typename .== (pgInt4 $ nodeTypeId NodeDocument)
returnA -< n
......@@ -166,7 +166,7 @@ joinInCorpus :: O.Query (NodeRead, NodeNodeReadNull)
joinInCorpus = leftJoin queryNodeTable queryNodeNodeTable cond
where
cond :: (NodeRead, NodeNodeRead) -> Column PGBool
cond (n, nn) = nn_node2_id nn .== (view node_id n)
cond (n, nn) = nn^.nn_node2_id .== (view node_id n)
------------------------------------------------------------------------
......
src/Gargantext/Database/Schema/NodeNodeNgrams.hs
View file @ e08e94f9
......@@ -25,7 +25,7 @@ module Gargantext.Database.Schema.NodeNodeNgrams
import Prelude
import Data.Maybe (Maybe)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
--import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Control.Lens.TH (makeLenses)
import Gargantext.Database.Utils (Cmd, mkCmd)
import Gargantext.Database.Schema.Ngrams (NgramsTypeId, pgNgramsTypeId, NgramsId)
import Gargantext.Database.Schema.Node (pgNodeId)
......@@ -35,12 +35,12 @@ import Opaleye
data NodeNodeNgramsPoly id' n1 n2 ngrams_id ngt w
= NodeNodeNgrams { nnng_id :: id'
, nnng_node1_id :: n1
, nnng_node2_id :: n2
, nnng_ngrams_id :: ngrams_id
, nnng_ngramsType :: ngt
, nnng_weight :: w
= NodeNodeNgrams { _nnng_id :: id'
, _nnng_node1_id :: n1
, _nnng_node2_id :: n2
, _nnng_ngrams_id :: ngrams_id
, _nnng_ngramsType :: ngt
, _nnng_weight :: w
} deriving (Show)
......@@ -71,19 +71,19 @@ type NodeNodeNgramsReadNull =
type NodeNodeNgrams =
NodeNodeNgramsPoly (Maybe Int) CorpusId DocId NgramsId NgramsTypeId Double
--{-
$(makeAdaptorAndInstance "pNodeNodeNgrams" ''NodeNodeNgramsPoly)
-- $(makeLensesWith abbreviatedFields ''NodeNodeNgramsPoly)
makeLenses ''NodeNodeNgramsPoly
nodeNodeNgramsTable :: Table NodeNodeNgramsWrite NodeNodeNgramsRead
nodeNodeNgramsTable = Table "node_node_ngrams"
( pNodeNodeNgrams NodeNodeNgrams
{ nnng_id = optional "id"
, nnng_node1_id = required "node1_id"
, nnng_node2_id = required "node2_id"
, nnng_ngrams_id = required "ngrams_id"
, nnng_ngramsType = required "ngrams_type"
, nnng_weight = required "weight"
{ _nnng_id = optional "id"
, _nnng_node1_id = required "node1_id"
, _nnng_node2_id = required "node2_id"
, _nnng_ngrams_id = required "ngrams_id"
, _nnng_ngramsType = required "ngrams_type"
, _nnng_weight = required "weight"
}
)
......
src/Gargantext/Database/TextSearch.hs
View file @ e08e94f9
......@@ -18,6 +18,7 @@ module Gargantext.Database.TextSearch where
import Data.Aeson
import Data.Map.Strict hiding (map, drop, take)
import Data.Maybe
import Control.Lens ((^.))
import Data.List (intersperse, take, drop)
import Data.String (IsString(..))
import Data.Text (Text, words, unpack, intercalate)
......@@ -43,97 +44,179 @@ import Opaleye hiding (Query, Order)
------------------------------------------------------------------------
searchInDatabase :: ParentId -> Text -> Cmd err [(NodeId, HyperdataDocument)]
searchInDatabase :: ParentId
-> Text
-> Cmd err [(NodeId, HyperdataDocument)]
searchInDatabase p t = runOpaQuery (queryInDatabase p t)
-- | Global search query where ParentId is Master Node Corpus Id
queryInDatabase :: ParentId -> Text -> O.Query (Column PGInt4, Column PGJsonb)
queryInDatabase _ q = proc () -> do
row <- queryNodeSearchTable -< ()
restrict -< (_ns_search row) @@ (pgTSQuery (unpack q))
restrict -< (_ns_typename row) .== (pgInt4 $ nodeTypeId NodeDocument)
returnA -< (_ns_id row, _ns_hyperdata row)
where
-- | Global search query where ParentId is Master Node Corpus Id
queryInDatabase :: ParentId -> Text -> O.Query (Column PGInt4, Column PGJsonb)
queryInDatabase _ q = proc () -> do
row <- queryNodeSearchTable -< ()
restrict -< (_ns_search row) @@ (pgTSQuery (unpack q))
restrict -< (_ns_typename row) .== (pgInt4 $ nodeTypeId NodeDocument)
returnA -< (_ns_id row, _ns_hyperdata row)
------------------------------------------------------------------------
-- | todo add limit and offset and order
searchInCorpus :: CorpusId -> IsTrash -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
searchInCorpus :: CorpusId
-> IsTrash
-> [Text]
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> Cmd err [FacetDoc]
searchInCorpus cId t q o l order = runOpaQuery (filterWith o l order $ queryInCorpus cId t q')
where
q' = intercalate " | " $ map stemIt q
queryInCorpus :: CorpusId -> IsTrash -> Text -> O.Query FacetDocRead
queryInCorpus :: CorpusId
-> IsTrash
-> Text
-> O.Query FacetDocRead
queryInCorpus cId t q = proc () -> do
(n, nn) <- joinInCorpus -< ()
restrict -< ( nn_node1_id nn) .== (toNullable $ pgNodeId cId)
restrict -< ( nn^.nn_node1_id) .== (toNullable $ pgNodeId cId)
restrict -< if t
then ( nn_category nn) .== (toNullable $ pgInt4 0)
else ( nn_category nn) .>= (toNullable $ pgInt4 1)
restrict -< (_ns_search n) @@ (pgTSQuery (unpack q))
restrict -< (_ns_typename n) .== (pgInt4 $ nodeTypeId NodeDocument)
returnA -< FacetDoc (_ns_id n) (_ns_date n) (_ns_name n) (_ns_hyperdata n) (nn_category nn) (nn_score nn)
then ( nn^.nn_category) .== (toNullable $ pgInt4 0)
else ( nn^.nn_category) .>= (toNullable $ pgInt4 1)
restrict -< (n ^. ns_search) @@ (pgTSQuery (unpack q))
restrict -< (n ^. ns_typename) .== (pgInt4 $ nodeTypeId NodeDocument)
returnA -< FacetDoc (n^.ns_id )
(n^.ns_date )
(n^.ns_name )
(n^.ns_hyperdata)
(nn^.nn_category)
(nn^.nn_score )
joinInCorpus :: O.Query (NodeSearchRead, NodeNodeReadNull)
joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
where
cond :: (NodeSearchRead, NodeNodeRead) -> Column PGBool
cond (n, nn) = nn_node2_id nn .== _ns_id n
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 -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop (maybe 0 identity o)
<$> map (\((i,u,h,s), ps) -> FacetPaired i u h s (catMaybes ps))
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 p) -> ((i,u,h,s), [maybePair p]))
<$> searchInCorpusWithContacts' cId q o l order
where
maybePair (Pair Nothing Nothing) = Nothing
maybePair (Pair _ Nothing) = Nothing
maybePair (Pair Nothing _) = Nothing
maybePair (Pair (Just p_id) (Just p_label)) = Just $ Pair p_id p_label
<$> 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 -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [(FacetPaired Int UTCTime HyperdataDocument Int (Pair (Maybe Int) (Maybe Text)))]
searchInCorpusWithContacts' cId q o l order = runOpaQuery $ queryInCorpusWithContacts cId q' o l order
where
q' = intercalate " | " $ map stemIt q
searchInCorpusWithContacts'
:: CorpusId
-> ListId
-> [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 q' o l order
where
q' = intercalate " | " $ map stemIt q
queryInCorpusWithContacts :: CorpusId -> Text -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> O.Query FacetPairedRead
queryInCorpusWithContacts cId q _ _ _ = proc () -> do
(docs, (corpusDoc, (_docNgrams, (ngrams', (_, contacts))))) <- joinInCorpusWithContacts -< ()
restrict -< (_ns_search docs) @@ (pgTSQuery $ unpack q )
restrict -< (_ns_typename docs) .== (pgInt4 $ nodeTypeId NodeDocument)
restrict -< (nn_node1_id corpusDoc) .== (toNullable $ pgNodeId cId)
queryInCorpusWithContacts
:: CorpusId
-> ListId
-> Text
-> Maybe Offset
-> Maybe Limit
-> Maybe OrderBy
-> O.Query FacetPairedRead
queryInCorpusWithContacts cId lId q _ _ _ = proc () -> do
(docs, (corpusDoc, (docNgrams, (ngrams', (_, contacts))))) <- joinInCorpusWithContacts -< ()
restrict -< (docs^.ns_search) @@ (pgTSQuery $ unpack q )
restrict -< (docs^.ns_typename) .== (pgInt4 $ nodeTypeId NodeDocument)
restrict -< (docNgrams^.nnng_node2_id) .== (toNullable $ pgNodeId lId)
restrict -< (corpusDoc^.nn_node1_id) .== (toNullable $ pgNodeId cId)
-- restrict -< (nng_listType docNgrams) .== (toNullable $ pgNgramsType Authors)
restrict -< (_node_typename contacts) .== (toNullable $ pgInt4 $ nodeTypeId NodeContact)
restrict -< (contacts^.node_typename) .== (toNullable $ pgInt4 $ nodeTypeId NodeContact)
-- let contact_id = ifThenElse (isNull $ _node_id contacts) (toNullable $ pgInt4 0) (_node_id contacts)
returnA -< FacetPaired (_ns_id docs) (_ns_date docs) (_ns_hyperdata docs) (pgInt4 0) (Pair (_node_id contacts) (ngrams_terms ngrams'))
returnA -< FacetPaired (docs^.ns_id) (docs^.ns_date) (docs^.ns_hyperdata) (pgInt4 0) (contacts^.node_id, ngrams'^.ngrams_terms)
joinInCorpusWithContacts :: O.Query (NodeSearchRead, (NodeNodeReadNull, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))))
joinInCorpusWithContacts = leftJoin6 queryNodeTable queryNodeNodeNgramsTable queryNgramsTable queryNodeNodeNgramsTable queryNodeNodeTable queryNodeSearchTable cond12 cond23 cond34 cond45 cond56
joinInCorpusWithContacts :: O.Query ( NodeSearchRead
, ( NodeNodeReadNull
, ( NodeNodeNgramsReadNull
, ( NgramsReadNull
, ( NodeNodeNgramsReadNull
, NodeReadNull
)
)
)
)
)
joinInCorpusWithContacts =
leftJoin6
queryNodeTable
queryNodeNodeNgramsTable
queryNgramsTable
queryNodeNodeNgramsTable
queryNodeNodeTable
queryNodeSearchTable
cond12
cond23
cond34
cond45
cond56
where
cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
cond12 (ng3, n2) = _node_id n2 .== nnng_node1_id ng3
---------
cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
cond23 (ng2, (nnng2, _)) = nnng_ngrams_id nnng2 .== ngrams_id ng2
cond34 :: (NodeNodeNgramsRead, (NgramsRead, (NodeNodeNgramsReadNull, NodeReadNull))) -> Column PGBool
cond34 (nng, (ng, (_,_))) = ngrams_id ng .== nnng_ngrams_id nng
cond45 :: (NodeNodeRead, (NodeNodeNgramsRead, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull)))) -> Column PGBool
cond45 (nn, (nng, (_,(_,_)))) = nnng_node1_id nng .== nn_node2_id nn
cond56 :: (NodeSearchRead, (NodeNodeRead, (NodeNodeNgramsReadNull, (NgramsReadNull, (NodeNodeNgramsReadNull, NodeReadNull))))) -> Column PGBool
cond56 (n, (nn, (_,(_,(_,_))))) = _ns_id n .== nn_node2_id nn
cond12 :: (NodeNodeNgramsRead, NodeRead) -> Column PGBool
cond12 (ng3, n2) = n2^.node_id .== ng3^.nnng_node1_id
cond23 :: (NgramsRead, (NodeNodeNgramsRead, NodeReadNull)) -> Column PGBool
cond23 (ng2, (nnng2, _)) = nnng2^.nnng_ngrams_id .== ng2^.ngrams_id
cond34 :: ( NodeNodeNgramsRead
, ( NgramsRead
, ( NodeNodeNgramsReadNull
, NodeReadNull
)
)
) -> Column PGBool
cond34 (nng, (ng, (_,_))) = ng^.ngrams_id .== nng^.nnng_ngrams_id
cond45 :: ( NodeNodeRead
, ( NodeNodeNgramsRead
, ( NgramsReadNull
, ( NodeNodeNgramsReadNull
, NodeReadNull
)
)
)
) -> Column PGBool
cond45 (nn, (nng, (_,(_,_)))) = nng^.nnng_node1_id .== nn^.nn_node2_id
cond56 :: ( NodeSearchRead
, ( NodeNodeRead
, ( NodeNodeNgramsReadNull
, ( NgramsReadNull
, ( NodeNodeNgramsReadNull
, NodeReadNull
)
)
)
)
) -> Column PGBool
cond56 (n, (nn, (_,(_,(_,_))))) = _ns_id n .== nn^.nn_node2_id
newtype TSQuery = UnsafeTSQuery [Text]
......
src/Gargantext/Database/Types/Node.hs
View file @ e08e94f9
......@@ -479,7 +479,7 @@ data NodePolySearch id typename userId
hyperdata search = NodeSearch { _ns_id :: id
, _ns_typename :: typename
, _ns_userId :: userId
-- , nodeUniqId :: hashId
-- , nodeUniqId :: shaId
, _ns_parentId :: parentId
, _ns_name :: name
, _ns_date :: date
......
src/Gargantext/Prelude/Utils.hs
View file @ e08e94f9
......@@ -85,7 +85,7 @@ writeFile :: (MonadReader env m, MonadIO m, HasSettings env, SaveFile a)
=> a -> m FilePath
writeFile a = do
dataPath <- view (settings . fileFolder) <$> ask
(fp,fn) <- liftIO $ (toPath 3) . hash . Text.pack . show <$> newStdGen
(fp,fn) <- liftIO $ (toPath 3) . sha . Text.pack . show <$> newStdGen
let foldPath = dataPath <> "/" <> fp
filePath = foldPath <> "/" <> fn
......
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