Skip to content

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

[TSVector] added for full text queries.

parent 53e751d3
Show whitespace changes
Inline Side-by-side
Showing with 127 additions and 97 deletions
install
View file @ 8f521836
......@@ -27,6 +27,7 @@ git clone ssh://git@gitlab.iscpif.fr:20022/gargantext/clustering-louvain.git
git clone https://github.com/np/servant-job.git
git clone https://github.com/np/patches-map
git clone https://gitlab.com/npouillard/patches-class.git
git clone https://github.com:delanoe/haskell-opaleye.git
cd ..
~/.local/bin/stack docker pull
......
package.yaml
View file @ 8f521836
name: gargantext
version: '4.0.0.2'
version: '4.0.0.3'
synopsis: Search, map, share
description: Please see README.md
category: Data
......
src/Gargantext/Database/Facet.hs
View file @ 8f521836
......@@ -50,7 +50,7 @@ import Gargantext.Database.NodeNgram
import Gargantext.Database.NodeNode
import Gargantext.Database.Queries
import Opaleye
import Opaleye.Internal.Join (NullMaker)
import Opaleye.Internal.Join (NullMaker(..))
import Prelude (Enum, Bounded, minBound, maxBound)
import Prelude hiding (null, id, map, sum, not, read)
import Servant.API
......@@ -193,8 +193,6 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable
cond45 (contact, (nodeNgram2, (_, (_,_)))) = _node_id contact .== nodeNgram_NodeNgramNodeId nodeNgram2
------------------------------------------------------------------------
runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd [FacetDoc]
......
src/Gargantext/Database/Flow/Utils.hs
View file @ 8f521836
......@@ -26,7 +26,7 @@ import Gargantext.Database.NodeNgram
toMaps :: Hyperdata a => (a -> Map (NgramsT Ngrams) Int) -> [Node a] -> Map (NgramsT Ngrams) (Map NodeId Int)
toMaps fun ns = mapNodeIdNgrams $ documentIdWithNgrams fun ns'
where
ns' = map (\(Node nId _ _ _ _ _ json) -> DocumentWithId nId json) ns
ns' = map (\(Node nId _ _ _ _ _ json _) -> DocumentWithId nId json) ns
mapNodeIdNgrams :: Hyperdata a => [DocumentIdWithNgrams a] -> Map (NgramsT Ngrams) (Map NodeId Int)
mapNodeIdNgrams ds = DM.map (DM.fromListWith (+)) $ DM.fromListWith (<>) xs
......
src/Gargantext/Database/Node.hs
View file @ 8f521836
......@@ -25,41 +25,35 @@ Portability : POSIX
module Gargantext.Database.Node where
import Data.Text (pack)
import GHC.Int (Int64)
import Control.Lens (set)
import Data.Maybe
import Data.Time (UTCTime)
import Database.PostgreSQL.Simple.FromField (FromField, fromField)
import Prelude hiding (null, id, map, sum)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Types
import Gargantext.Core.Types.Individu (Username)
import Gargantext.Database.Utils (fromField')
import Gargantext.Database.Types.Node (NodeType, defaultCorpus, Hyperdata)
import Gargantext.Database.Queries
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Prelude hiding (sum, head)
import Gargantext.Core.Types.Main (UserId)
import Control.Applicative (Applicative)
import Control.Arrow (returnA)
import Control.Lens (set)
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Aeson
import Data.Maybe (Maybe, fromMaybe)
import Data.Text (Text)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import qualified Data.ByteString as DB
import qualified Data.ByteString.Lazy as DBL
import Data.ByteString (ByteString)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Data.Text (Text, unpack, pack)
import Data.Time (UTCTime)
import Database.PostgreSQL.Simple (Connection)
import Database.PostgreSQL.Simple.FromField (FromField, fromField)
import GHC.Int (Int64)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Types
import Gargantext.Core.Types.Individu (Username)
import Gargantext.Core.Types.Main (UserId)
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Queries
import Gargantext.Database.Types.Node (NodeType, defaultCorpus, Hyperdata)
import Gargantext.Database.Utils (fromField')
import Gargantext.Prelude hiding (sum, head)
import Opaleye hiding (FromField)
import Opaleye.Internal.QueryArr (Query)
import Prelude hiding (null, id, map, sum)
import qualified Data.ByteString as DB
import qualified Data.ByteString.Lazy as DBL
import qualified Data.Profunctor.Product as PP
------------------------------------------------------------------------
......@@ -141,6 +135,12 @@ instance QueryRunnerColumnDefault PGJsonb HyperdataList
instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault PGTSVector (Maybe TSVector)
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
------------------------------------------------------------------------
$(makeAdaptorAndInstance "pNode" ''NodePoly)
......@@ -151,11 +151,13 @@ nodeTable :: Table NodeWrite NodeRead
nodeTable = Table "nodes" (pNode Node { _node_id = optional "id"
, _node_typename = required "typename"
, _node_userId = required "user_id"
, _node_parentId = required "parent_id"
, _node_name = required "name"
, _node_date = optional "date"
, _node_hyperdata = required "hyperdata"
-- , node_titleAbstract = optional "title_abstract"
, _node_search = optional "search"
}
)
......@@ -167,6 +169,7 @@ nodeTable' :: Table (Maybe (Column PGInt4)
, Column PGText
,Maybe (Column PGTimestamptz)
, Column PGJsonb
,Maybe (Column PGTSVector)
)
((Column PGInt4)
, Column PGInt4
......@@ -175,15 +178,19 @@ nodeTable' :: Table (Maybe (Column PGInt4)
, Column PGText
,(Column PGTimestamptz)
, Column PGJsonb
, Column PGTSVector
)
nodeTable' = Table "nodes" (PP.p7 ( optional "id"
nodeTable' = Table "nodes" (PP.p8 ( optional "id"
, required "typename"
, required "user_id"
, optional "parent_id"
, required "name"
, optional "date"
, required "hyperdata"
, optional "search"
)
)
......@@ -197,6 +204,7 @@ selectNode id = proc () -> do
restrict -< _node_id row .== id
returnA -< row
runGetNodes :: Query NodeRead -> Cmd [NodeAny]
runGetNodes q = mkCmd $ \conn -> runQuery conn q
......@@ -216,7 +224,7 @@ selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' parentId maybeNodeType = proc () -> do
node <- (proc () -> do
row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
row@(Node _ typeId _ parentId' _ _ _ _) <- queryNodeTable -< ()
restrict -< parentId' .== (toNullable $ pgInt4 parentId)
let typeId' = maybe 0 nodeTypeId maybeNodeType
......@@ -237,12 +245,12 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
deleteNode :: Int -> Cmd Int
deleteNode n = mkCmd $ \conn ->
fromIntegral <$> runDelete conn nodeTable
(\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
(\(Node n_id _ _ _ _ _ _ _) -> n_id .== pgInt4 n)
deleteNodes :: [Int] -> Cmd Int
deleteNodes ns = mkCmd $ \conn ->
fromIntegral <$> runDelete conn nodeTable
(\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
(\(Node n_id _ _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
getNodesWith :: JSONB a => Connection -> Int -> proxy a -> Maybe NodeType
......@@ -281,7 +289,7 @@ getCorporaWithParentId' n = mkCmd $ \conn -> runQuery conn $ selectNodesWith' n
------------------------------------------------------------------------
selectNodesWithParentID :: Int -> Query NodeRead
selectNodesWithParentID n = proc () -> do
row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
row@(Node _ _ _ parent_id _ _ _ _) <- queryNodeTable -< ()
restrict -< if n > 0
then parent_id .== (toNullable $ pgInt4 n)
else isNull parent_id
......@@ -289,7 +297,7 @@ selectNodesWithParentID n = proc () -> do
selectNodesWithType :: Column PGInt4 -> Query NodeRead
selectNodesWithType type_id = proc () -> do
row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
row@(Node _ tn _ _ _ _ _ _) <- queryNodeTable -< ()
restrict -< tn .== type_id
returnA -< row
......@@ -308,7 +316,7 @@ getNodesWithType conn type_id = do
-- TODO Classe HasDefault where
-- default NodeType = Hyperdata
------------------------------------------------------------------------
type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString
type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString (Maybe TSVector)
------------------------------------------------------------------------
defaultUser :: HyperdataUser
defaultUser = HyperdataUser (Just $ (pack . show) EN)
......@@ -388,24 +396,29 @@ nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard
------------------------------------------------------------------------
node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite'
node nodeType name hyperData parentId userId = Node Nothing typeId userId parentId name Nothing byteData
node nodeType name hyperData parentId userId = Node Nothing typeId userId parentId name Nothing byteData Nothing
where
typeId = nodeTypeId nodeType
byteData = DB.pack . DBL.unpack $ encode hyperData
-------------------------------
node2row :: (Functor maybe1, Functor maybe2, Functor maybe3) =>
NodePoly (maybe2 Int) Int Int (maybe1 Int)
Text (maybe3 UTCTime) ByteString
-> (maybe2 (Column PGInt4), Column PGInt4, Column PGInt4, maybe1 (Column PGInt4)
, Column PGText, maybe3 (Column PGTimestamptz), Column PGJsonb)
node2row (Node id tn ud pid nm dt hp) = ((pgInt4 <$> id)
node2row :: (Functor maybe1, Functor maybe2, Functor maybe3, Functor maybe4) =>
NodePoly (maybe1 Int) Int Int
(maybe2 Int) Text (maybe3 UTCTime)
ByteString (maybe4 TSVector)
-> ( maybe1 (Column PGInt4), Column PGInt4, Column PGInt4
, maybe2 (Column PGInt4), Column PGText, maybe3 (Column PGTimestamptz)
, Column PGJsonb, maybe4 (Column PGTSVector))
node2row (Node id tn ud pid nm dt hp tv) = ((pgInt4 <$> id)
,(pgInt4 tn)
,(pgInt4 ud)
,(pgInt4 <$> pid)
,(pgStrictText nm)
,(pgUTCTime <$> dt)
,(pgStrictJSONB hp)
,(pgTSVector . unpack <$> tv)
)
------------------------------------------------------------------------
insertNodesR' :: [NodeWrite'] -> Cmd [Int]
......@@ -415,7 +428,7 @@ insertNodes :: [NodeWrite'] -> Connection -> IO Int64
insertNodes ns conn = runInsertMany conn nodeTable' (map node2row ns)
insertNodesR :: [NodeWrite'] -> Connection -> IO [Int]
insertNodesR ns conn = runInsertManyReturning conn nodeTable' (map node2row ns) (\(i,_,_,_,_,_,_) -> i)
insertNodesR ns conn = runInsertManyReturning conn nodeTable' (map node2row ns) (\(i,_,_,_,_,_,_,_) -> i)
-------------------------
insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
insertNodesWithParent pid ns conn = insertNodes (map (set node_parentId pid) ns) conn
......@@ -441,7 +454,7 @@ post c uid pid [ Node' NodeCorpus "name" "{}" []
-- needs a Temporary type between Node' and NodeWriteT
node2table :: UserId -> Maybe ParentId -> Node' -> NodeWriteT
node2table uid pid (Node' nt txt v []) = ( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (fmap pgInt4 pid)
, pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)
, pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v, Nothing)
node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
......@@ -459,6 +472,7 @@ type NodeWriteT = ( Maybe (Column PGInt4)
, Column PGText
, Maybe (Column PGTimestamptz)
, Column PGJsonb
, Maybe (Column PGTSVector)
)
......@@ -466,7 +480,7 @@ mkNode' :: [NodeWriteT] -> Cmd Int64
mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable' ns
mkNodeR' :: [NodeWriteT] -> Cmd [Int]
mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_,_) -> i)
------------------------------------------------------------------------
......
src/Gargantext/Database/Node/Children.hs
View file @ 8f521836
......@@ -40,7 +40,7 @@ getChildren c pId _ maybeNodeType maybeOffset maybeLimit = runQuery c
selectChildren :: ParentId -> Maybe NodeType -> Query NodeRead
selectChildren parentId maybeNodeType = proc () -> do
row@(Node nId typeName _ parent_id _ _ _) <- queryNodeTable -< ()
row@(Node nId typeName _ parent_id _ _ _ _) <- queryNodeTable -< ()
(NodeNode n1id n2id _ _ _) <- queryNodeNodeTable -< ()
let nodeType = maybe 0 nodeTypeId maybeNodeType
......
src/Gargantext/Database/Queries.hs
View file @ 8f521836
......@@ -37,7 +37,7 @@ type NodeWrite = NodePoly (Maybe (Column PGInt4 ))
(Column (PGText ))
(Maybe (Column PGTimestamptz))
(Column PGJsonb )
-- (Maybe (Column PGTSVector))
(Maybe (Column PGTSVector))
type NodeRead = NodePoly (Column PGInt4 )
(Column PGInt4 )
......@@ -46,8 +46,7 @@ type NodeRead = NodePoly (Column PGInt4 )
(Column (PGText ))
(Column PGTimestamptz )
(Column PGJsonb)
-- (Column PGTSVector)
(Column PGTSVector)
type NodeReadNull = NodePoly (Column (Nullable PGInt4 ))
......@@ -57,8 +56,7 @@ type NodeReadNull = NodePoly (Column (Nullable PGInt4 ))
(Column (Nullable PGText ))
(Column (Nullable PGTimestamptz ))
(Column (Nullable PGJsonb))
(Column (Nullable PGTSVector))
join3 :: Query columnsA -> Query columnsB -> Query columnsC
......
src/Gargantext/Database/TextSearch.hs
View file @ 8f521836
......@@ -10,6 +10,7 @@ Portability : POSIX
-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
......@@ -26,13 +27,30 @@ import Database.PostgreSQL.Simple.ToField
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Types.Node (NodeType(..))
import Gargantext.Prelude
import Gargantext.Database.Node
import Gargantext.Database.Queries
import Gargantext.Core.Types
import Control.Arrow (returnA)
import qualified Opaleye as O hiding (Order)
import Opaleye hiding (Query, Order)
newtype TSQuery = UnsafeTSQuery [Text]
searchQuery :: O.Query NodeRead
searchQuery = proc () -> do
row <- queryNodeTable -< ()
restrict -< (_node_search row) @@ (pgTSQuery "test")
returnA -< row
-- | TODO [""] -> panic "error"
toTSQuery :: [Text] -> TSQuery
toTSQuery txt = UnsafeTSQuery txt
instance IsString TSQuery
where
fromString = UnsafeTSQuery . words . cs
......@@ -48,9 +66,6 @@ instance ToField TSQuery
]
) xs
type ParentId = Int
type Limit = Int
type Offset = Int
data Order = Asc | Desc
instance ToField Order
......
src/Gargantext/Database/Types/Node.hs
View file @ 8f521836
......@@ -63,8 +63,6 @@ type UTCTime' = UTCTime
instance Arbitrary UTCTime' where
arbitrary = elements $ timesAfter 100 D (jour 2000 01 01)
------------------------------------------------------------------------
data Status = Status { status_failed :: Int
, status_succeeded :: Int
......@@ -324,18 +322,15 @@ instance Hyperdata HyperdataNotebook
-- | NodePoly indicates that Node has a Polymorphism Type
type Node json = NodePoly NodeId NodeTypeId NodeUserId (Maybe NodeParentId) NodeName UTCTime json -- NodeVector
type Node json = NodePoly NodeId NodeTypeId NodeUserId (Maybe NodeParentId) NodeName UTCTime json (Maybe TSVector)
-- type Node json = NodePoly NodeId NodeTypeId UserId ParentId NodeName UTCTime json
type NodeTypeId = Int
type NodeParentId = Int
type NodeUserId = Int
type NodeName = Text
--type NodeVector = Vector
type TSVector = Text
--type NodeUser = Node HyperdataUser
type NodeAny = Node HyperdataAny
-- | Then a Node can be either a Folder or a Corpus or a Document
type NodeUser = Node HyperdataUser
......@@ -347,6 +342,9 @@ type NodeDocument = Node HyperdataDocument
type NodeAnnuaire = Node HyperdataAnnuaire
-- | Any others nodes
type NodeAny = Node HyperdataAny
---- | Then a Node can be either a Graph or a Phylo or a Notebook
type NodeList = Node HyperdataList
type NodeGraph = Node HyperdataGraph
......@@ -379,24 +377,30 @@ instance ToParamSchema NodeType
instance ToSchema NodeType
------------------------------------------------------------------------
data NodePoly id typename userId parentId name date hyperdata = Node { _node_id :: id
data NodePoly id typename userId
parentId name date
hyperdata search = Node { _node_id :: id
, _node_typename :: typename
, _node_userId :: userId
-- , nodeUniqId :: hashId
, _node_parentId :: parentId
, _node_name :: name
, _node_date :: date
, _node_hyperdata :: hyperdata
, _node_search :: search
} deriving (Show, Generic)
$(deriveJSON (unPrefix "_node_") ''NodePoly)
$(makeLenses ''NodePoly)
instance Arbitrary hyperdata => Arbitrary (NodePoly NodeId NodeTypeId (Maybe NodeUserId) NodeParentId NodeName UTCTime hyperdata) where
arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) <$> arbitrary
instance Arbitrary hyperdata => Arbitrary (NodePoly NodeId NodeTypeId NodeUserId (Maybe NodeParentId) NodeName UTCTime hyperdata) where
arbitrary = Node 1 1 1 (Just 1) "name" (jour 2018 01 01) <$> arbitrary
instance Arbitrary hyperdata => Arbitrary (NodePoly NodeId NodeTypeId
(Maybe NodeUserId) NodeParentId NodeName
UTCTime hyperdata (Maybe TSVector)) where
--arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
arbitrary = Node <$> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary
------------------------------------------------------------------------
hyperdataDocument :: HyperdataDocument
hyperdataDocument = case decode docExample of
......@@ -438,18 +442,17 @@ instance ToSchema hyperdata =>
ToSchema (NodePoly NodeId NodeTypeId
(Maybe NodeUserId)
NodeParentId NodeName
UTCTime hyperdata
UTCTime hyperdata TSVector
)
instance ToSchema hyperdata =>
ToSchema (NodePoly NodeId NodeTypeId
NodeUserId
(Maybe NodeParentId) NodeName
UTCTime hyperdata
UTCTime hyperdata TSVector
)
instance ToSchema Status
stack.yaml
View file @ 8f521836
......@@ -7,6 +7,7 @@ packages:
- 'deps/clustering-louvain'
- 'deps/patches-map'
- 'deps/patches-class'
- 'deps/haskell-opaleye'
allow-newer: true
extra-deps:
......@@ -17,7 +18,7 @@ extra-deps:
- git: https://github.com/delanoe/servant-static-th.git
commit: ba5347e7d8a13ce5275af8470c15b2305fbb23af
- accelerate-1.2.0.0
- opaleye-0.6.7002.0
#- opaleye-0.6.7002.0
- aeson-lens-0.5.0.0
- duckling-0.1.3.0
- full-text-search-0.2.1.4
......
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