diff --git a/src/Gargantext/API.hs b/src/Gargantext/API.hs
index d2bea33cdfc53245f48811f5035971618cc8eef2..dcd1069c8b501a641f0ac6d7d5104856fd9c904d 100644
--- a/src/Gargantext/API.hs
+++ b/src/Gargantext/API.hs
@@ -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"
diff --git a/src/Gargantext/API/Node.hs b/src/Gargantext/API/Node.hs
index 614fbaa114bb8eb0b56ac08aa4e654b8753f9601..8f5cf841b4e1e8337050385c28e38e4ddbbf7196 100644
--- a/src/Gargantext/API/Node.hs
+++ b/src/Gargantext/API/Node.hs
@@ -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
diff --git a/src/Gargantext/API/Search.hs b/src/Gargantext/API/Search.hs
index 15f341cfa205360379edc038ffa95a825f748038..c391ebc13a2f176360811ccf111e3d6e052647fb 100644
--- a/src/Gargantext/API/Search.hs
+++ b/src/Gargantext/API/Search.hs
@@ -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 =
diff --git a/src/Gargantext/API/Table.hs b/src/Gargantext/API/Table.hs
index e0948db5e44d6123006650d7b6fcf988a7e79281..c12778b682df9f25e6600aebe6932176361dad63 100644
--- a/src/Gargantext/API/Table.hs
+++ b/src/Gargantext/API/Table.hs
@@ -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)
-
+-}
diff --git a/src/Gargantext/Database/Facet.hs b/src/Gargantext/Database/Facet.hs
index a1cfa87792002c8bf6eed2e828da87b0dc5ab466..14d5d36e86299144eb8d5bb04a877c10ec6a6eea 100644
--- a/src/Gargantext/Database/Facet.hs
+++ b/src/Gargantext/Database/Facet.hs
@@ -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)
------------------------------------------------------------------------
diff --git a/src/Gargantext/Database/Flow.hs b/src/Gargantext/Database/Flow.hs
index a495cbd1db0b32737d42ec527f67659196f69d07..14bae2d3b8da50aec1af65de3dd5bc30be1157dc 100644
--- a/src/Gargantext/Database/Flow.hs
+++ b/src/Gargantext/Database/Flow.hs
@@ -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
diff --git a/src/Gargantext/Database/Flow/Pairing.hs b/src/Gargantext/Database/Flow/Pairing.hs
index bf63f489b747bafbdc9287b759702c408041e2c7..26a7554ea83e0a15d61622c5344a5680087552c6 100644
--- a/src/Gargantext/Database/Flow/Pairing.hs
+++ b/src/Gargantext/Database/Flow/Pairing.hs
@@ -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
--}
-
-
diff --git a/src/Gargantext/Database/Flow/Utils.hs b/src/Gargantext/Database/Flow/Utils.hs
index cbab70099e406d9909b904aef785776120752174..e695d1e344b12264535f934f2e8d2364f238028b 100644
--- a/src/Gargantext/Database/Flow/Utils.hs
+++ b/src/Gargantext/Database/Flow/Utils.hs
@@ -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
diff --git a/src/Gargantext/Database/Ngrams.hs b/src/Gargantext/Database/Ngrams.hs
index 3f6a5a63b917c4268f433263d86db4e7454efb93..f93f10e0509a6d33f26785fed81cb97681b4486c 100644
--- a/src/Gargantext/Database/Ngrams.hs
+++ b/src/Gargantext/Database/Ngrams.hs
@@ -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
diff --git a/src/Gargantext/Database/Node/Children.hs b/src/Gargantext/Database/Node/Children.hs
index 3dbcfaee1634697d46b7d86d775ce20a2a1e0a1f..75ec3dcafd4e68754dd772f9f151003fbaedea31 100644
--- a/src/Gargantext/Database/Node/Children.hs
+++ b/src/Gargantext/Database/Node/Children.hs
@@ -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))
diff --git a/src/Gargantext/Database/Node/Document/Insert.hs b/src/Gargantext/Database/Node/Document/Insert.hs
index ac01121d2ca6f6b1df638fc48880363da193f09b..f1c0d37d7a0c2798c8f159a8d76751eff2b50c63 100644
--- a/src/Gargantext/Database/Node/Document/Insert.hs
+++ b/src/Gargantext/Database/Node/Document/Insert.hs
@@ -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
]
diff --git a/src/Gargantext/Database/Schema/Ngrams.hs b/src/Gargantext/Database/Schema/Ngrams.hs
index b9da31004219232cadf90e39e31e8543ac887d2a..d9f784774d161834681f27ca94ac7459193353ff 100644
--- a/src/Gargantext/Database/Schema/Ngrams.hs
+++ b/src/Gargantext/Database/Schema/Ngrams.hs
@@ -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"
}
)
diff --git a/src/Gargantext/Database/Schema/Node.hs b/src/Gargantext/Database/Schema/Node.hs
index 4c9726961a26a2c09a2c6e38401328c7590d3aa3..e755bd4daeeb923e3c8285ed4e05885dd50e0f4f 100644
--- a/src/Gargantext/Database/Schema/Node.hs
+++ b/src/Gargantext/Database/Schema/Node.hs
@@ -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)
-
-
diff --git a/src/Gargantext/Database/Schema/NodeNode.hs b/src/Gargantext/Database/Schema/NodeNode.hs
index a2e9d198ed55e18430c1dcfcf564146112890efc..2504769e58665b5b15524d49df5ba9fc7d8850a7 100644
--- a/src/Gargantext/Database/Schema/NodeNode.hs
+++ b/src/Gargantext/Database/Schema/NodeNode.hs
@@ -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)
------------------------------------------------------------------------
diff --git a/src/Gargantext/Database/Schema/NodeNodeNgrams.hs b/src/Gargantext/Database/Schema/NodeNodeNgrams.hs
index d09aca7f22a516b3c9c96307e28e19dce37f08ba..e3bc10f2b30e79c686eb06a4e36ae9c62324015d 100644
--- a/src/Gargantext/Database/Schema/NodeNodeNgrams.hs
+++ b/src/Gargantext/Database/Schema/NodeNodeNgrams.hs
@@ -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"
}
)
diff --git a/src/Gargantext/Database/TextSearch.hs b/src/Gargantext/Database/TextSearch.hs
index e9f593062dda5358f3999b6f97f232becace6734..d2bc22e8293bd0c53c8c0c88a65d2922714f72f4 100644
--- a/src/Gargantext/Database/TextSearch.hs
+++ b/src/Gargantext/Database/TextSearch.hs
@@ -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]
diff --git a/src/Gargantext/Database/Types/Node.hs b/src/Gargantext/Database/Types/Node.hs
index 482a18624c1b9798fa0497feeb8569443ed915be..fc97b0af113f909b259dc21d8fb5756b34f98629 100644
--- a/src/Gargantext/Database/Types/Node.hs
+++ b/src/Gargantext/Database/Types/Node.hs
@@ -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
diff --git a/src/Gargantext/Prelude/Utils.hs b/src/Gargantext/Prelude/Utils.hs
index e21b8eabe5d3d4c82a66232b3b3f140518cf06cf..c5e96b9cc0fd14154aab40f0bbbece44e7b9421d 100644
--- a/src/Gargantext/Prelude/Utils.hs
+++ b/src/Gargantext/Prelude/Utils.hs
@@ -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