Commit 2618ee47 authored by Alexandre Delanoë's avatar Alexandre Delanoë

[FIX] Doc Table fixed

parent 156790ff
...@@ -147,7 +147,7 @@ type NodeTableResult a = TableResult (Node a) ...@@ -147,7 +147,7 @@ type NodeTableResult a = TableResult (Node a)
data TableResult a = TableResult { tr_count :: Int data TableResult a = TableResult { tr_count :: Int
, tr_docs :: [a] , tr_docs :: [a]
} deriving (Generic) } deriving (Generic, Show)
$(deriveJSON (unPrefix "tr_") ''TableResult) $(deriveJSON (unPrefix "tr_") ''TableResult)
......
...@@ -33,21 +33,21 @@ import Data.Time (UTCTime) ...@@ -33,21 +33,21 @@ import Data.Time (UTCTime)
import Database.PostgreSQL.Simple.FromField (FromField, fromField) import Database.PostgreSQL.Simple.FromField (FromField, fromField)
import Database.PostgreSQL.Simple.ToField (ToField, toField) import Database.PostgreSQL.Simple.ToField (ToField, toField)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Servant import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
import qualified Opaleye as O import Gargantext.Database.Schema.Context
import Gargantext.Database.Schema.Node
import Gargantext.Prelude
import Gargantext.Prelude.Crypto.Hash (Hash)
import Opaleye (DefaultFromField, defaultFromField, SqlInt4, SqlText, SqlTSVector, Nullable, fromPGSFromField) import Opaleye (DefaultFromField, defaultFromField, SqlInt4, SqlText, SqlTSVector, Nullable, fromPGSFromField)
import Servant hiding (Context)
import Test.QuickCheck (elements) import Test.QuickCheck (elements)
import Gargantext.Prelude.Crypto.Hash (Hash)
import Test.QuickCheck.Arbitrary import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Instances.Text () import Test.QuickCheck.Instances.Text ()
import Test.QuickCheck.Instances.Time () import Test.QuickCheck.Instances.Time ()
import Text.Read (read) import Text.Read (read)
import qualified Opaleye as O
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
-- import Gargantext.Database.Prelude (fromField')
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.Context
import Gargantext.Prelude
type UserId = Int type UserId = Int
type MasterUserId = UserId type MasterUserId = UserId
...@@ -441,4 +441,8 @@ instance DefaultFromField SqlText (Maybe Hash) ...@@ -441,4 +441,8 @@ instance DefaultFromField SqlText (Maybe Hash)
where where
defaultFromField = fromPGSFromField defaultFromField = fromPGSFromField
---------------------------------------------------------------------
context2node :: Context a -> Node a
context2node (Context ci ch ct cu cp cn cd chy) = Node ci ch ct cu cp cn cd chy
...@@ -148,16 +148,14 @@ runPGSQuery_ :: ( CmdM env err m ...@@ -148,16 +148,14 @@ runPGSQuery_ :: ( CmdM env err m
runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError
where where
printError (SomeException e) = do printError (SomeException e) = do
printDebug "[G.D.P.runPGSQuery_]" ("TODO: format query error query" :: Text) printDebug "[G.D.P.runPGSQuery_]" ("TODO: format query error" :: Text)
throw (SomeException e) throw (SomeException e)
execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
------------------------------------------------------------------------ ------------------------------------------------------------------------
databaseParameters :: FilePath -> IO PGS.ConnectInfo databaseParameters :: FilePath -> IO PGS.ConnectInfo
databaseParameters fp = do databaseParameters fp = do
ini <- readIniFile' fp ini <- readIniFile' fp
......
...@@ -23,10 +23,15 @@ import Gargantext.Core.Types ...@@ -23,10 +23,15 @@ import Gargantext.Core.Types
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument, HyperdataContact) import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument, HyperdataContact)
import Gargantext.Database.Prelude import Gargantext.Database.Prelude
import Gargantext.Database.Query.Filter import Gargantext.Database.Query.Filter
import Gargantext.Database.Query.Table.NodeNode
import Gargantext.Database.Schema.Node import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.Context
import Gargantext.Database.Schema.NodeContext
import Gargantext.Database.Query.Table.NodeContext
import Gargantext.Prelude
import Opaleye import Opaleye
import Protolude
-- TODO getAllTableDocuments -- TODO getAllTableDocuments
...@@ -46,6 +51,7 @@ getAllChildren :: (JSONB a, HasDBid NodeType) ...@@ -46,6 +51,7 @@ getAllChildren :: (JSONB a, HasDBid NodeType)
-> Cmd err (NodeTableResult a) -> Cmd err (NodeTableResult a)
getAllChildren pId p maybeNodeType = getChildren pId p maybeNodeType Nothing Nothing getAllChildren pId p maybeNodeType = getChildren pId p maybeNodeType Nothing Nothing
getChildren :: (JSONB a, HasDBid NodeType) getChildren :: (JSONB a, HasDBid NodeType)
=> ParentId => ParentId
-> proxy a -> proxy a
...@@ -53,31 +59,75 @@ getChildren :: (JSONB a, HasDBid NodeType) ...@@ -53,31 +59,75 @@ getChildren :: (JSONB a, HasDBid NodeType)
-> Maybe Offset -> Maybe Offset
-> Maybe Limit -> Maybe Limit
-> Cmd err (NodeTableResult a) -> Cmd err (NodeTableResult a)
getChildren pId _ maybeNodeType maybeOffset maybeLimit = do getChildren pId p t@(Just NodeDocument) maybeOffset maybeLimit = getChildrenContext pId p t maybeOffset maybeLimit
getChildren pId p t@(Just NodeContact ) maybeOffset maybeLimit = getChildrenContext pId p t maybeOffset maybeLimit
getChildren a b c d e = getChildrenNode a b c d e
getChildrenNode :: (JSONB a, HasDBid NodeType)
=> ParentId
-> proxy a
-> Maybe NodeType
-> Maybe Offset
-> Maybe Limit
-> Cmd err (NodeTableResult a)
getChildrenNode pId _ maybeNodeType maybeOffset maybeLimit = do
printDebug "getChildrenNode" (pId, maybeNodeType)
let query = selectChildrenNode pId maybeNodeType
docs <- runOpaQuery docs <- runOpaQuery
$ limit' maybeLimit $ offset' maybeOffset $ limit' maybeLimit
$ offset' maybeOffset
$ orderBy (asc _node_id) $ orderBy (asc _node_id)
$ query $ query
docCount <- runCountOpaQuery query docCount <- runCountOpaQuery query
pure $ TableResult { tr_docs = docs, tr_count = docCount } pure $ TableResult { tr_docs = docs, tr_count = docCount }
where
query = selectChildren pId maybeNodeType
selectChildren :: HasDBid NodeType selectChildrenNode :: HasDBid NodeType
=> ParentId => ParentId
-> Maybe NodeType -> Maybe NodeType
-> Select NodeRead -> Select NodeRead
selectChildren parentId maybeNodeType = proc () -> do selectChildrenNode parentId maybeNodeType = proc () -> do
row@(Node nId _ typeName _ parent_id _ _ _) <- queryNodeTable -< () row@(Node _ _ typeName _ parent_id _ _ _) <- queryNodeTable -< ()
(NodeNode n1id n2id _ _) <- queryNodeNodeTable -< () let nodeType = maybe 0 toDBid maybeNodeType
restrict -< typeName .== sqlInt4 nodeType
restrict -< parent_id .== (pgNodeId parentId)
returnA -< row
getChildrenContext :: (JSONB a, HasDBid NodeType)
=> ParentId
-> proxy a
-> Maybe NodeType
-> Maybe Offset
-> Maybe Limit
-> Cmd err (NodeTableResult a)
getChildrenContext pId _ maybeNodeType maybeOffset maybeLimit = do
printDebug "getChildrenContext" (pId, maybeNodeType)
let query = selectChildren' pId maybeNodeType
docs <- runOpaQuery
$ limit' maybeLimit
$ offset' maybeOffset
$ orderBy (asc _context_id)
$ query
docCount <- runCountOpaQuery query
pure $ TableResult { tr_docs = map context2node docs, tr_count = docCount }
selectChildren' :: HasDBid NodeType
=> ParentId
-> Maybe NodeType
-> Select ContextRead
selectChildren' parentId maybeNodeType = proc () -> do
row@(Context cid _ typeName _ _ _ _ _) <- queryContextTable -< ()
(NodeContext nid cid' _ _) <- queryNodeContextTable -< ()
let nodeType = maybe 0 toDBid maybeNodeType let nodeType = maybe 0 toDBid maybeNodeType
restrict -< typeName .== sqlInt4 nodeType restrict -< typeName .== sqlInt4 nodeType
restrict -< (.||) (parent_id .== (pgNodeId parentId)) restrict -< nid .== pgNodeId parentId
( (.&&) (n1id .== pgNodeId parentId) restrict -< cid .== cid'
(n2id .== nId))
returnA -< row returnA -< row
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