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
Expand all Show 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 #-}
......@@ -120,9 +117,12 @@ _flowCorpusApi u n tt l q = do
------------------------------------------------------------------------
-- 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
......@@ -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
......@@ -254,13 +282,16 @@ insertMasterDocs c lang hs = do
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,7 +311,9 @@ getOrMkRoot username = do
getOrMkRootWithCorpus :: (HasNodeError err, MkCorpus a)
=> Username -> Either CorpusName [CorpusId] -> Maybe a
=> Username
-> Either CorpusName [CorpusId]
-> Maybe a
-> Cmd err (UserId, RootId, CorpusId)
getOrMkRootWithCorpus username cName c = do
(userId, rootId) <- getOrMkRoot username
......@@ -301,14 +334,18 @@ 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) )
toInserted :: [ReturnId]
-> Map HashId ReturnId
toInserted =
Map.fromList . map (\r -> (reUniqId r, r) )
. filter (\r -> reInserted r == True)
data DocumentWithId a = DocumentWithId
......@@ -361,10 +398,13 @@ 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
......@@ -389,7 +429,6 @@ instance ExtractNgramsT HyperdataDocument
<> [(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)
filterNgramsT s ms = Map.fromList $ map (\a -> filter' s a) $ Map.toList ms
......@@ -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,21 +96,25 @@ 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
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
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.node_id = nn.node2_id
AND occ.node2_id = nn.node2_id
GROUP BY n.id;
|]
......@@ -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,17 +30,27 @@ 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 -< ()
......
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))
......@@ -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
This diff is collapsed.
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