Commit 8f521836 authored by Alexandre Delanoë's avatar Alexandre Delanoë

[TSVector] added for full text queries.

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