Skip to content

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

[Database][Schema] Node Table and types without TSVector.

parent 0d46ed5e
Show whitespace changes
Inline Side-by-side
Showing with 69 additions and 52 deletions
package.yaml
View file @ 5c9f985b
......@@ -36,6 +36,7 @@ library:
- Gargantext.Core.Types.Main
- Gargantext.Core.Utils.Prefix
- Gargantext.Database
- Gargantext.Database.Flow
- Gargantext.Database.Schema.Node
- Gargantext.Database.Cooc
- Gargantext.Database.Tree
......
src/Gargantext/Core/Types/Main.hs
View file @ 5c9f985b
......@@ -21,7 +21,6 @@ Portability : POSIX
module Gargantext.Core.Types.Main where
------------------------------------------------------------------------
import Prelude (Enum, Bounded, minBound, maxBound)
import Data.Aeson (FromJSON, ToJSON, toJSON)
import Data.Aeson as A
......
src/Gargantext/Database/Flow/Utils.hs
View file @ 5c9f985b
......@@ -26,7 +26,7 @@ import Gargantext.Database.Schema.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/Children.hs
View file @ 5c9f985b
......@@ -41,7 +41,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/Schema/Node.hs
View file @ 5c9f985b
......@@ -125,10 +125,6 @@ $(makeLensesWith abbreviatedFields ''NodePoly)
$(makeAdaptorAndInstance "pNodeSearch" ''NodePolySearch)
$(makeLensesWith abbreviatedFields ''NodePolySearch)
type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString (Maybe TSVector)
type NodeWrite = NodePoly (Maybe (Column PGInt4 ))
(Column PGInt4 )
(Column PGInt4 )
......@@ -136,7 +132,6 @@ type NodeWrite = NodePoly (Maybe (Column PGInt4 ))
(Column (PGText ))
(Maybe (Column PGTimestamptz))
(Column PGJsonb )
(Maybe (Column PGTSVector))
type NodeRead = NodePoly (Column PGInt4 )
(Column PGInt4 )
......@@ -145,7 +140,6 @@ type NodeRead = NodePoly (Column PGInt4 )
(Column (PGText ))
(Column PGTimestamptz )
(Column PGJsonb)
(Column PGTSVector)
type NodeReadNull = NodePoly (Column (Nullable PGInt4 ))
......@@ -155,8 +149,6 @@ type NodeReadNull = NodePoly (Column (Nullable PGInt4 ))
(Column (Nullable PGText ))
(Column (Nullable PGTimestamptz ))
(Column (Nullable PGJsonb))
(Column (Nullable PGTSVector))
nodeTable :: Table NodeWrite NodeRead
nodeTable = Table "nodes" (pNode Node { _node_id = optional "id"
......@@ -168,11 +160,16 @@ nodeTable = Table "nodes" (pNode Node { _node_id = optional "id"
, _node_date = optional "date"
, _node_hyperdata = required "hyperdata"
, _node_search = optional "search"
}
)
queryNodeTable :: Query NodeRead
queryNodeTable = queryTable nodeTable
-- | TODO remove below
type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString
--{-
nodeTable' :: Table (Maybe (Column PGInt4)
, Column PGInt4
, Column PGInt4
......@@ -180,7 +177,6 @@ nodeTable' :: Table (Maybe (Column PGInt4)
, Column PGText
,Maybe (Column PGTimestamptz)
, Column PGJsonb
,Maybe (Column PGTSVector)
)
((Column PGInt4)
, Column PGInt4
......@@ -189,10 +185,9 @@ nodeTable' :: Table (Maybe (Column PGInt4)
, Column PGText
,(Column PGTimestamptz)
, Column PGJsonb
, Column PGTSVector
)
nodeTable' = Table "nodes" (PP.p8 ( optional "id"
nodeTable' = Table "nodes" (PP.p7 ( optional "id"
, required "typename"
, required "user_id"
......@@ -201,18 +196,13 @@ nodeTable' = Table "nodes" (PP.p8 ( optional "id"
, optional "date"
, required "hyperdata"
, optional "search"
)
)
queryNodeTable :: Query NodeRead
queryNodeTable = queryTable nodeTable
--}
------------------------------------------------------------------------
-- | Node(Read|Write)Search is slower than Node(Write|Read) use it
-- for full text search only
type NodeSearchWrite = NodePolySearch (Maybe (Column PGInt4 ))
(Column PGInt4 )
(Column PGInt4 )
......@@ -288,7 +278,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
......@@ -309,12 +299,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
......@@ -353,7 +343,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
......@@ -361,7 +351,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
......@@ -456,20 +446,20 @@ 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 Nothing
node nodeType name hyperData parentId userId = Node Nothing typeId userId parentId name Nothing byteData
where
typeId = nodeTypeId nodeType
byteData = DB.pack . DBL.unpack $ encode hyperData
-------------------------------
node2row :: (Functor maybe1, Functor maybe2, Functor maybe3, Functor maybe4) =>
node2row :: (Functor maybe1, Functor maybe2, Functor maybe3) =>
NodePoly (maybe1 Int) Int Int
(maybe2 Int) Text (maybe3 UTCTime)
ByteString (maybe4 TSVector)
ByteString
-> ( 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)
, Column PGJsonb)
node2row (Node id tn ud pid nm dt hp) = ((pgInt4 <$> id)
,(pgInt4 tn)
,(pgInt4 ud)
......@@ -478,7 +468,6 @@ node2row (Node id tn ud pid nm dt hp tv) = ((pgInt4 <$> id)
,(pgUTCTime <$> dt)
,(pgStrictJSONB hp)
,(pgTSVector . unpack <$> tv)
)
------------------------------------------------------------------------
insertNodesR' :: [NodeWrite'] -> Cmd [Int]
......@@ -488,7 +477,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
......@@ -514,7 +503,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, Nothing)
, pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)
node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
......@@ -524,7 +513,7 @@ data Node' = Node' { _n_type :: NodeType
, _n_children :: [Node']
} deriving (Show)
-- | TODO mv in Database.Schema and factor
type NodeWriteT = ( Maybe (Column PGInt4)
, Column PGInt4
, Column PGInt4
......@@ -532,7 +521,6 @@ type NodeWriteT = ( Maybe (Column PGInt4)
, Column PGText
, Maybe (Column PGTimestamptz)
, Column PGJsonb
, Maybe (Column PGTSVector)
)
......@@ -540,7 +528,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/Types/Node.hs
View file @ 5c9f985b
......@@ -322,8 +322,7 @@ instance Hyperdata HyperdataNotebook
-- | NodePoly indicates that Node has a Polymorphism Type
type Node json = NodePoly NodeId NodeTypeId NodeUserId (Maybe NodeParentId) NodeName UTCTime json (Maybe TSVector)
type NodeSearch json = NodePoly NodeId NodeTypeId NodeUserId (Maybe NodeParentId) NodeName UTCTime json (Maybe TSVector)
type Node json = NodePoly NodeId NodeTypeId NodeUserId (Maybe NodeParentId) NodeName UTCTime json
-- type Node json = NodePoly NodeId NodeTypeId UserId ParentId NodeName UTCTime json
type NodeTypeId = Int
......@@ -380,16 +379,16 @@ instance ToSchema NodeType
------------------------------------------------------------------------
data NodePoly id typename userId
parentId name date
hyperdata search = Node { _node_id :: id
hyperdata = 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)
......@@ -411,6 +410,7 @@ data NodePolySearch id typename userId
$(deriveJSON (unPrefix "_ns_") ''NodePolySearch)
$(makeLenses ''NodePolySearch)
type NodeSearch json = NodePolySearch NodeId NodeTypeId NodeUserId (Maybe NodeParentId) NodeName UTCTime json (Maybe TSVector)
------------------------------------------------------------------------
......@@ -420,11 +420,25 @@ instance (Arbitrary hyperdata
,Arbitrary nodeUserId
,Arbitrary nodeParentId
) => Arbitrary (NodePoly nodeId nodeTypeId nodeUserId nodeParentId
NodeName UTCTime hyperdata (Maybe TSVector)) where
NodeName UTCTime hyperdata) where
--arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
arbitrary = Node <$> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary
instance (Arbitrary hyperdata
,Arbitrary nodeId
,Arbitrary nodeTypeId
,Arbitrary nodeUserId
,Arbitrary nodeParentId
) => Arbitrary (NodePolySearch nodeId nodeTypeId nodeUserId nodeParentId
NodeName UTCTime hyperdata (Maybe TSVector)) where
--arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
arbitrary = NodeSearch <$> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary
------------------------------------------------------------------------
hyperdataDocument :: HyperdataDocument
hyperdataDocument = case decode docExample of
......@@ -466,11 +480,26 @@ instance ToSchema hyperdata =>
ToSchema (NodePoly NodeId NodeTypeId
(Maybe NodeUserId)
NodeParentId NodeName
UTCTime hyperdata (Maybe TSVector)
UTCTime hyperdata
)
instance ToSchema hyperdata =>
ToSchema (NodePoly NodeId NodeTypeId
NodeUserId
(Maybe NodeParentId) NodeName
UTCTime hyperdata
)
instance ToSchema hyperdata =>
ToSchema (NodePolySearch NodeId NodeTypeId
(Maybe NodeUserId)
NodeParentId NodeName
UTCTime hyperdata (Maybe TSVector)
)
instance ToSchema hyperdata =>
ToSchema (NodePolySearch NodeId NodeTypeId
NodeUserId
(Maybe NodeParentId) NodeName
UTCTime hyperdata (Maybe TSVector)
......
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