Skip to content

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

[NewType] Merge, NodeNgram* fix.

parents 6cacf848 3e2fa028
Pipeline #111 canceled with stage
    Show whitespace changes
    Inline Side-by-side
    Showing with 174 additions and 149 deletions
    src/Gargantext/API.hs
    View file @ a759d5d6
    ......@@ -83,7 +83,7 @@ import Gargantext.API.Node ( GargServer
    , HyperdataAnnuaire
    )
    --import Gargantext.Database.Node.Contact (HyperdataContact)
    import Gargantext.Database.Types.Node ()
    import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
    import Gargantext.API.Count ( CountAPI, count, Query)
    import Gargantext.API.Search ( SearchAPI, search, SearchQuery)
    import Gargantext.Database.Facet
    ......@@ -222,19 +222,19 @@ type GargAPI' =
    -- Node endpoint
    :<|> "node" :> Summary "Node endpoint"
    :> Capture "id" Int :> NodeAPI HyperdataAny
    :> Capture "id" NodeId :> NodeAPI HyperdataAny
    -- Corpus endpoint
    :<|> "corpus":> Summary "Corpus endpoint"
    :> Capture "id" Int :> NodeAPI HyperdataCorpus
    :> Capture "id" CorpusId :> NodeAPI HyperdataCorpus
    -- Annuaire endpoint
    :<|> "annuaire":> Summary "Annuaire endpoint"
    :> Capture "id" Int :> NodeAPI HyperdataAnnuaire
    :> Capture "id" AnnuaireId :> NodeAPI HyperdataAnnuaire
    -- Corpus endpoint
    :<|> "nodes" :> Summary "Nodes endpoint"
    :> ReqBody '[JSON] [Int] :> NodesAPI
    :> ReqBody '[JSON] [NodeId] :> NodesAPI
    -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI
    -- Corpus endpoint
    ......@@ -250,11 +250,11 @@ type GargAPI' =
    :> SearchAPI
    :<|> "graph" :> Summary "Graph endpoint"
    :> Capture "id" Int :> GraphAPI
    :> Capture "id" NodeId :> GraphAPI
    -- Tree endpoint
    :<|> "tree" :> Summary "Tree endpoint"
    :> Capture "id" Int :> TreeAPI
    :> Capture "id" NodeId :> TreeAPI
    -- :<|> "scraper" :> WithCallbacks ScraperAPI
    ......
    src/Gargantext/API/Auth.hs
    View file @ a759d5d6
    ......@@ -35,7 +35,7 @@ import Data.Text (Text, reverse)
    import GHC.Generics (Generic)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Database.Root (getRoot)
    import Gargantext.Database.Types.Node (NodePoly(_node_id))
    import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId)
    import Gargantext.Database.Utils (Cmd)
    import Gargantext.Prelude hiding (reverse)
    import Test.QuickCheck (elements, oneof)
    ......@@ -67,7 +67,7 @@ data AuthValid = AuthValid { _authVal_token :: Token
    deriving (Generic)
    type Token = Text
    type TreeId = Int
    type TreeId = NodeId
    -- | Main functions of authorization
    ......
    src/Gargantext/API/Node.hs
    View file @ a759d5d6
    ......@@ -62,7 +62,8 @@ import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
    import Gargantext.Viz.Graph hiding (Node)-- (Graph(_graph_metadata),LegendField(..), GraphMetadata(..),readGraphFromJson,defaultGraph)
    -- import Gargantext.Core (Lang(..))
    import Gargantext.Core.Types (Offset, Limit)
    import Gargantext.Core.Types.Main (Tree, NodeTree, CorpusId, ContactId)
    import Gargantext.Core.Types.Main (Tree, NodeTree)
    import Gargantext.Database.Types.Node (CorpusId, ContactId)
    -- import Gargantext.Text.Terms (TermType(..))
    import Test.QuickCheck (elements)
    ......@@ -117,13 +118,13 @@ type NodeAPI a = Get '[JSON] (Node a)
    :> QueryParam "order" OrderBy
    :> SearchAPI
    type RenameApi = Summary " RenameNode Node"
    type RenameApi = Summary " Rename Node"
    :> ReqBody '[JSON] RenameNode
    :> Put '[JSON] [Int]
    type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
    :> ReqBody '[JSON] PostNode
    :> Post '[JSON] [Int]
    :> Post '[JSON] [NodeId]
    type ChildrenApi a = Summary " Summary children"
    :> QueryParam "type" NodeType
    ......@@ -322,7 +323,7 @@ getChart :: NodeId -> Maybe UTCTime -> Maybe UTCTime
    -> Cmd err [FacetChart]
    getChart _ _ _ = undefined -- TODO
    postNode :: NodeId -> PostNode -> Cmd err [Int]
    postNode :: NodeId -> PostNode -> Cmd err [NodeId]
    postNode pId (PostNode name nt) = mk nt (Just pId) name
    putNode :: NodeId -> Cmd err Int
    ......
    src/Gargantext/API/Search.hs
    View file @ a759d5d6
    ......@@ -45,7 +45,7 @@ import Gargantext.Database.Utils (Cmd)
    -- | SearchIn [NodesId] if empty then global search
    -- TODO [Int]
    data SearchQuery = SearchQuery { sq_query :: [Text]
    , sq_corpus_id :: Int
    , sq_corpus_id :: NodeId
    } deriving (Generic)
    $(deriveJSON (unPrefix "sq_") ''SearchQuery)
    instance ToSchema SearchQuery where
    ......
    src/Gargantext/Core/Types/Main.hs
    View file @ a759d5d6
    ......@@ -42,7 +42,7 @@ import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
    ------------------------------------------------------------------------
    data NodeTree = NodeTree { _nt_name :: Text
    , _nt_type :: NodeType
    , _nt_id :: Int
    , _nt_id :: NodeId
    } deriving (Show, Read, Generic)
    $(deriveJSON (unPrefix "_nt_") ''NodeTree)
    ......@@ -80,24 +80,9 @@ corpusTree nId t = TreeN (NodeTree ("Corpus " <> t) NodeCorpus nId) ( [ leafT
    --data Classification = Favorites | MyClassifcation
    type UserId = Int
    type MasterUserId = Int
    type RootId = Int
    type MasterCorpusId = Int
    type HashId = Text
    type AnnuaireId = NodeId
    type ContactId = NodeId
    type CorpusId = NodeId
    type DocumentId = NodeId
    type DocId = DocumentId -- todo: remove this
    type ListId = NodeId
    type TypeId = Int
    -- TODO multiple ListType declaration, remove it
    data ListType = StopList | CandidateList | GraphList
    deriving (Generic, Eq, Ord, Show, Enum, Bounded)
    ......@@ -152,7 +137,6 @@ type TirankGlobal = Tficf
    type ErrorMessage = Text
    -- Queries
    type ParentId = NodeId
    type Limit = Int
    type Offset = Int
    ......
    src/Gargantext/Database/Facet.hs
    View file @ a759d5d6
    ......@@ -219,7 +219,7 @@ viewAuthorsDoc cId _ nt = proc () -> do
    -- restrict -< nodeNode_delete nn .== (pgBool t)
    -}
    restrict -< _node_id contact .== (toNullable $ pgInt4 cId)
    restrict -< _node_id contact .== (toNullable $ pgNodeId cId)
    restrict -< _node_typename doc .== (pgInt4 $ nodeTypeId nt)
    returnA -< FacetDoc (_node_id doc) (_node_date doc) (_node_name doc) (_node_hyperdata doc) (pgBool True) (pgInt4 1)
    ......@@ -255,7 +255,7 @@ viewDocuments cId t ntId = proc () -> do
    n <- queryNodeTable -< ()
    nn <- queryNodeNodeTable -< ()
    restrict -< _node_id n .== nodeNode_node2_id nn
    restrict -< nodeNode_node1_id nn .== (pgInt4 cId)
    restrict -< nodeNode_node1_id nn .== (pgNodeId cId)
    restrict -< _node_typename n .== (pgInt4 ntId)
    restrict -< nodeNode_delete nn .== (pgBool t)
    returnA -< FacetDoc (_node_id n) (_node_date n) (_node_name n) (_node_hyperdata n) (nodeNode_favorite nn) (pgInt4 1)
    ......
    src/Gargantext/Database/Flow.hs
    View file @ a759d5d6
    ......@@ -42,8 +42,7 @@ import Gargantext.Database.Schema.Node (mkRoot, mkCorpus, getOrMkList, mkGraph,
    import Gargantext.Database.Schema.NodeNgram (NodeNgramPoly(..), insertNodeNgrams)
    import Gargantext.Database.Schema.NodeNgramsNgrams (NodeNgramsNgramsPoly(..), insertNodeNgramsNgramsNew)
    import Gargantext.Database.Schema.User (getUser, UserLight(..))
    import Gargantext.Database.Types.Node (HyperdataDocument(..))
    import Gargantext.Database.Types.Node (NodeType(..), NodeId)
    import Gargantext.Database.Types.Node (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
    import Gargantext.Database.Utils (Cmd)
    import Gargantext.Text.Terms (TermType(..))
    import Gargantext.Ext.IMT (toSchoolName)
    ......@@ -53,6 +52,7 @@ import Gargantext.Text.Parsers (parseDocs, FileFormat)
    import System.FilePath (FilePath)
    import qualified Data.Map as DM
    flowCorpus :: HasNodeError err => FileFormat -> FilePath -> CorpusName -> Cmd err CorpusId
    flowCorpus ff fp cName = do
    hyperdataDocuments' <- map addUniqIdsDoc <$> liftIO (parseDocs ff fp)
    ......@@ -284,7 +284,7 @@ flowList uId cId ngs = do
    pure lId
    flowListUser :: HasNodeError err => UserId -> CorpusId -> Cmd err Int
    flowListUser :: HasNodeError err => UserId -> CorpusId -> Cmd err NodeId
    flowListUser uId cId = getOrMkList cId uId
    ------------------------------------------------------------------------
    ......
    src/Gargantext/Database/Flow/Pairing.hs
    View file @ a759d5d6
    ......@@ -37,8 +37,8 @@ import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
    import Gargantext.Database.Node.Contact
    import Gargantext.Database.Flow.Utils
    import Gargantext.Database.Utils (Cmd, runPGSQuery)
    import Gargantext.Database.Types.Node (AnnuaireId, CorpusId, ContactId)
    import Gargantext.Database.Node.Children
    import Gargantext.Core.Types.Main
    import Gargantext.Core.Types (NodeType(..))
    -- TODO mv this type in Types Main
    ......
    src/Gargantext/Database/Node/Children.hs
    View file @ a759d5d6
    ......@@ -26,6 +26,7 @@ import Gargantext.Database.Schema.NodeNode
    import Gargantext.Database.Config (nodeTypeId)
    import Gargantext.Database.Queries.Filter
    import Gargantext.Database.Node.Contact (HyperdataContact)
    import Gargantext.Database.Schema.Node (pgNodeId)
    import Control.Arrow (returnA)
    -- | TODO: use getChildren with Proxy ?
    ......@@ -47,8 +48,8 @@ selectChildren parentId maybeNodeType = proc () -> do
    let nodeType = maybe 0 nodeTypeId maybeNodeType
    restrict -< typeName .== pgInt4 nodeType
    restrict -< (.||) (parent_id .== (pgInt4 parentId))
    ( (.&&) (n1id .== pgInt4 parentId)
    restrict -< (.||) (parent_id .== (pgNodeId parentId))
    ( (.&&) (n1id .== pgNodeId parentId)
    (n2id .== nId))
    returnA -< row
    ......
    src/Gargantext/Database/Node/Contact.hs
    View file @ a759d5d6
    ......@@ -28,9 +28,8 @@ import Data.Time (UTCTime)
    import Database.PostgreSQL.Simple.FromField (FromField, fromField)
    import GHC.Generics (Generic)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Core.Types.Main (AnnuaireId, UserId)
    import Gargantext.Database.Schema.Node (NodeWrite, Name, node)
    import Gargantext.Database.Types.Node (Node,Hyperdata,NodeType(..))
    import Gargantext.Database.Types.Node (Node,Hyperdata,NodeType(..), UserId, AnnuaireId)
    import Gargantext.Database.Utils (fromField')
    import Gargantext.Prelude
    import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn)
    ......
    src/Gargantext/Database/Node/Document/Add.hs
    View file @ a759d5d6
    ......@@ -40,7 +40,6 @@ import Gargantext.Prelude
    import GHC.Generics (Generic)
    ---------------------------------------------------------------------------
    type ParentId = Int
    add :: ParentId -> [NodeId] -> Cmd err [Only Int]
    add pId ns = runPGSQuery queryAdd (Only $ Values fields inputData)
    ......
    src/Gargantext/Database/Node/Document/Insert.hs
    View file @ a759d5d6
    ......@@ -180,7 +180,7 @@ prepare uId pId nodeType = map (\h -> InputData tId uId pId (name h) (toJSON' h)
    -- | When documents are inserted
    -- ReturnType after insertion
    data ReturnId = ReturnId { reInserted :: Bool -- ^ if the document is inserted (True: is new, False: is not new)
    , reId :: Int -- ^ always return the id of the document (even new or 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
    } deriving (Show, Generic)
    ......@@ -190,9 +190,6 @@ instance FromRow ReturnId where
    -- ** Insert Types
    type UserId = Int
    type ParentId = Int
    data InputData = InputData { inTypenameId :: NodeTypeId
    , inUserId :: UserId
    , inParentId :: ParentId
    ......
    src/Gargantext/Database/Node/Update.hs
    View file @ a759d5d6
    ......@@ -17,20 +17,18 @@ Portability : POSIX
    module Gargantext.Database.Node.Update (Update(..), update) where
    import Data.Text (Text)
    import qualified Data.Text as DT
    import Database.PostgreSQL.Simple
    import Gargantext.Prelude
    import Gargantext.Database.Utils
    import Gargantext.Database.Types.Node (NodeId, ParentId)
    import Gargantext.Database.Schema.Node (Name)
    -- import Data.ByteString
    --rename :: NodeId -> Text -> IO ByteString
    --rename nodeId name = formatPGSQuery "UPDATE nodes SET name=? where id=?" (name,nodeId)
    ------------------------------------------------------------------------
    type NodeId = Int
    type Name = Text
    type ParentId = Int
    data Update = Rename NodeId Name
    | Move NodeId ParentId
    ......
    src/Gargantext/Database/Schema/Ngrams.hs
    View file @ a759d5d6
    ......@@ -221,8 +221,8 @@ getNgramsTableDb nt ngrt ntp@(NgramsTableParam listIdUser _) limit_ offset_ = do
    data NgramsTableParam =
    NgramsTableParam { _nt_listId :: Int
    , _nt_corpusId :: Int
    NgramsTableParam { _nt_listId :: NodeId
    , _nt_corpusId :: NodeId
    }
    type NgramsTableParamUser = NgramsTableParam
    ......@@ -289,8 +289,8 @@ querySelectTableNgrams = [sql|
    |]
    type ListIdUser = Int
    type ListIdMaster = Int
    type ListIdUser = NodeId
    type ListIdMaster = NodeId
    type MapToChildren = Map Text (Set Text)
    type MapToParent = Map Text Text
    ......
    src/Gargantext/Database/Schema/Node.hs
    View file @ a759d5d6
    ......@@ -38,7 +38,6 @@ 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.Filter (limit', offset')
    import Gargantext.Database.Types.Node (NodeType, defaultCorpus, Hyperdata)
    ......@@ -140,10 +139,15 @@ instance QueryRunnerColumnDefault PGTSVector (Maybe TSVector)
    where
    queryRunnerColumnDefault = fieldQueryRunnerColumn
    instance QueryRunnerColumnDefault PGInt4 (Maybe NodeParentId)
    instance QueryRunnerColumnDefault PGInt4 (Maybe NodeId)
    where
    queryRunnerColumnDefault = fieldQueryRunnerColumn
    instance QueryRunnerColumnDefault PGInt4 NodeId
    where
    queryRunnerColumnDefault = fieldQueryRunnerColumn
    ------------------------------------------------------------------------
    -- WIP
    -- TODO Classe HasDefault where
    ......@@ -269,7 +273,7 @@ selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
    selectNodesWith' parentId maybeNodeType = proc () -> do
    node <- (proc () -> do
    row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
    restrict -< parentId' .== (pgInt4 parentId)
    restrict -< parentId' .== (pgNodeId parentId)
    let typeId' = maybe 0 nodeTypeId maybeNodeType
    ......@@ -280,46 +284,46 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
    returnA -< node
    deleteNode :: Int -> Cmd err Int
    deleteNode :: NodeId -> Cmd err Int
    deleteNode n = mkCmd $ \conn ->
    fromIntegral <$> runDelete conn nodeTable
    (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
    (\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
    deleteNodes :: [Int] -> Cmd err Int
    deleteNodes :: [NodeId] -> Cmd err Int
    deleteNodes ns = mkCmd $ \conn ->
    fromIntegral <$> runDelete conn nodeTable
    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
    -- TODO: NodeType should match with `a'
    getNodesWith :: JSONB a => Int -> proxy a -> Maybe NodeType
    getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
    -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
    getNodesWith parentId _ nodeType maybeOffset maybeLimit =
    runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
    -- TODO: Why is the second parameter ignored?
    -- TODO: Why not use getNodesWith?
    getNodesWithParentId :: Int -> Maybe Text -> Cmd err [NodeAny]
    getNodesWithParentId :: NodeId -> Maybe Text -> Cmd err [NodeAny]
    getNodesWithParentId n _ = runOpaQuery $ selectNodesWithParentID n
    ------------------------------------------------------------------------
    getDocumentsV3WithParentId :: Int -> Cmd err [Node HyperdataDocumentV3]
    getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
    getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
    -- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
    getDocumentsWithParentId :: Int -> Cmd err [Node HyperdataDocument]
    getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
    getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
    getListsWithParentId :: Int -> Cmd err [Node HyperdataList]
    getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
    getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
    getCorporaWithParentId :: Int -> Cmd err [Node HyperdataCorpus]
    getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
    getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
    ------------------------------------------------------------------------
    selectNodesWithParentID :: Int -> Query NodeRead
    selectNodesWithParentID :: NodeId -> Query NodeRead
    selectNodesWithParentID n = proc () -> do
    row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
    restrict -< parent_id .== (pgInt4 n)
    restrict -< parent_id .== (pgNodeId n)
    returnA -< row
    selectNodesWithType :: Column PGInt4 -> Query NodeRead
    ......@@ -330,9 +334,9 @@ selectNodesWithType type_id = proc () -> do
    type JSONB = QueryRunnerColumnDefault PGJsonb
    getNode :: JSONB a => Int -> proxy a -> Cmd err (Node a)
    getNode id _ = do
    fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runOpaQuery (limit 1 $ selectNode (pgInt4 id))
    getNode :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
    getNode nId _ = do
    fromMaybe (error $ "Node does node exist: " <> show nId) . headMay <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
    getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
    getNodesWithType = runOpaQuery . selectNodesWithType
    ......@@ -415,7 +419,7 @@ 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 (pgInt4 typeId) (pgInt4 userId) (pgInt4 <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
    node nodeType name hyperData parentId userId = Node Nothing (pgInt4 typeId) (pgInt4 userId) (pgNodeId <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
    where
    typeId = nodeTypeId nodeType
    ......@@ -423,15 +427,15 @@ node nodeType name hyperData parentId userId = Node Nothing (pgInt4 typeId) (pgI
    insertNodes :: [NodeWrite] -> Cmd err Int64
    insertNodes ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
    insertNodesR :: [NodeWrite] -> Cmd err [Int]
    insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
    insertNodesR ns = mkCmd $ \conn ->
    runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
    insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
    insertNodesWithParent pid ns = insertNodes (set node_parentId (pgInt4 <$> pid) <$> ns)
    insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
    insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [Int]
    insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgInt4 <$> pid) <$> ns)
    insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
    insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
    ------------------------------------------------------------------------
    -- TODO Hierachy of Nodes
    -- post and get same types Node' and update if changes
    ......@@ -447,10 +451,10 @@ post c uid pid [ Node' NodeCorpus "name" "{}" []
    ------------------------------------------------------------------------
    -- TODO
    -- currently this function remove the child relation
    -- currently this function removes the child relation
    -- needs a Temporary type between Node' and NodeWriteT
    node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
    node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4$ nodeTypeId nt) (pgInt4 uid) (fmap pgInt4 pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
    node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
    node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
    ......@@ -463,20 +467,19 @@ data Node' = Node' { _n_type :: NodeType
    mkNode :: [NodeWrite] -> Cmd err Int64
    mkNode ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
    mkNodeR :: [NodeWrite] -> Cmd err [Int]
    mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
    mkNodeR ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
    ------------------------------------------------------------------------
    data NewNode = NewNode { _newNodeId :: Int
    , _newNodeChildren :: [Int] }
    data NewNode = NewNode { _newNodeId :: NodeId
    , _newNodeChildren :: [NodeId] }
    -- | postNode
    postNode :: HasNodeError err => UserId -> Maybe ParentId -> Node' -> Cmd err NewNode
    postNode uid pid (Node' nt txt v []) = do
    pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
    case pids of
    [pid] -> pure $ NewNode pid []
    [pid'] -> pure $ NewNode pid' []
    _ -> nodeError ManyParents
    postNode uid pid (Node' NodeCorpus txt v ns) = do
    ......@@ -497,33 +500,34 @@ childWith uId pId (Node' NodeContact txt v []) = node2table uId (Just pId) (Nod
    childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a child"
    mk :: NodeType -> Maybe ParentId -> Text -> Cmd err [Int]
    -- | TODO Use right userId
    mk :: NodeType -> Maybe ParentId -> Text -> Cmd err [NodeId]
    mk nt pId name = mk' nt userId pId name
    where
    userId = 1
    mk' :: NodeType -> UserId -> Maybe ParentId -> Text -> Cmd err [Int]
    mk' nt uId pId name = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId]
    mk' :: NodeType -> UserId -> Maybe ParentId -> Text -> Cmd err [NodeId]
    mk' nt uId pId name = insertNodesWithParentR pId [node nt name hd pId uId]
    where
    hd = HyperdataUser . Just . pack $ show EN
    type Name = Text
    mk'' :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [Int]
    mk'' :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
    mk'' NodeUser Nothing uId name = mk' NodeUser uId Nothing name
    mk'' NodeUser _ _ _ = nodeError UserNoParent
    mk'' _ Nothing _ _ = nodeError HasParent
    mk'' nt pId uId name = mk' nt uId pId name
    mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [Int]
    mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
    mkRoot uname uId = case uId > 0 of
    False -> nodeError NegativeId
    True -> mk'' NodeUser Nothing uId uname
    mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd err [Int]
    mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd err [CorpusId]
    mkCorpus n h p u = insertNodesR [nodeCorpusW n h p u]
    getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err Int
    getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err NodeId
    getOrMkList pId uId =
    maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
    where
    ......@@ -534,17 +538,19 @@ defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
    defaultList cId =
    maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
    mkList :: HasNodeError err => ParentId -> UserId -> Cmd err [Int]
    mkList :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
    mkList p u = insertNodesR [nodeListW Nothing Nothing p u]
    mkGraph :: ParentId -> UserId -> Cmd err [Int]
    mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
    mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
    mkDashboard :: ParentId -> UserId -> Cmd err [Int]
    mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
    mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
    mkAnnuaire :: ParentId -> UserId -> Cmd err [Int]
    mkAnnuaire :: ParentId -> UserId -> Cmd err [NodeId]
    mkAnnuaire p u = insertNodesR [nodeAnnuaireW Nothing Nothing p u]
    -- | Default CorpusId Master and ListId Master
    pgNodeId :: NodeId -> Column PGInt4
    pgNodeId = pgInt4 . id2int
    src/Gargantext/Database/Schema/NodeNgram.hs
    View file @ a759d5d6
    ......@@ -36,9 +36,11 @@ import Control.Monad (void)
    import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
    import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
    import Database.PostgreSQL.Simple.SqlQQ (sql)
    import Gargantext.Core.Types.Main (ListId, ListTypeId)
    import Gargantext.Core.Types.Main (ListTypeId)
    import Gargantext.Database.Utils (mkCmd, Cmd, execPGSQuery)
    import Gargantext.Database.Schema.NodeNgramsNgrams
    import Gargantext.Database.Types.Node (NodeId, ListId)
    import Gargantext.Database.Schema.Node (pgNodeId)
    import Gargantext.Database.Schema.NodeNgramsNgrams (NgramsChild, NgramsParent, ngramsGroup, Action(..))
    import Gargantext.Prelude
    import Opaleye
    import qualified Database.PostgreSQL.Simple as PGS (Only(..))
    ......@@ -77,7 +79,7 @@ type NodeNgramReadNull =
    (Column (Nullable PGInt4 ))
    type NodeNgram =
    NodeNgramPoly (Maybe Int) Int Int Double Int
    NodeNgramPoly (Maybe NodeId) NodeId Int Double Int
    $(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
    $(makeLensesWith abbreviatedFields ''NodeNgramPoly)
    ......@@ -100,7 +102,7 @@ queryNodeNgramTable = queryTable nodeNgramTable
    insertNodeNgrams :: [NodeNgram] -> Cmd err Int
    insertNodeNgrams = insertNodeNgramW
    . map (\(NodeNgram _ n g w t) ->
    NodeNgram Nothing (pgInt4 n) (pgInt4 g)
    NodeNgram Nothing (pgNodeId n) (pgInt4 g)
    (pgDouble w) (pgInt4 t)
    )
    ......
    src/Gargantext/Database/Schema/NodeNgramsNgrams.hs
    View file @ a759d5d6
    ......@@ -42,7 +42,8 @@ import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
    import Database.PostgreSQL.Simple.SqlQQ (sql)
    import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
    import Gargantext.Database.Utils (Cmd, runOpaQuery, execPGSQuery, connection)
    import Gargantext.Core.Types.Main (ListId)
    import Gargantext.Database.Types.Node (ListId)
    import Gargantext.Database.Schema.Node (pgNodeId)
    import Gargantext.Prelude
    import Opaleye
    import qualified Database.PostgreSQL.Simple as PGS
    ......@@ -67,7 +68,7 @@ type NodeNgramsNgramsRead =
    (Column PGFloat8)
    type NodeNgramsNgrams =
    NodeNgramsNgramsPoly Int
    NodeNgramsNgramsPoly ListId
    Int
    Int
    (Maybe Double)
    ......@@ -108,7 +109,7 @@ instance QueryRunnerColumnDefault PGFloat8 (Maybe Double) where
    insertNodeNgramsNgramsNew :: [NodeNgramsNgrams] -> Cmd err Int
    insertNodeNgramsNgramsNew = insertNodeNgramsNgramsW
    . map (\(NodeNgramsNgrams n ng1 ng2 maybeWeight) ->
    NodeNgramsNgrams (pgInt4 n )
    NodeNgramsNgrams (pgNodeId n )
    (pgInt4 ng1)
    (pgInt4 ng2)
    (pgDouble <$> maybeWeight)
    ......
    src/Gargantext/Database/Schema/NodeNode.hs
    View file @ a759d5d6
    ......@@ -32,7 +32,7 @@ import Control.Lens.TH (makeLensesWith, abbreviatedFields)
    import Data.Maybe (Maybe)
    import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
    import Gargantext.Database.Utils
    import Gargantext.Core.Types.Main (CorpusId, DocId)
    import Gargantext.Database.Types.Node (CorpusId, DocId)
    import Gargantext.Prelude
    import Opaleye
    ......
    src/Gargantext/Database/TextSearch.hs
    View file @ a759d5d6
    ......@@ -64,7 +64,7 @@ searchInCorpus cId q o l order = runOpaQuery (filterWith o l order $ queryInCorp
    queryInCorpus :: CorpusId -> Text -> O.Query FacetDocRead
    queryInCorpus cId q = proc () -> do
    (n, nn) <- joinInCorpus -< ()
    restrict -< ( nodeNode_node1_id nn) .== (toNullable $ pgInt4 cId)
    restrict -< ( nodeNode_node1_id nn) .== (toNullable $ pgNodeId cId)
    restrict -< (_ns_search n) @@ (pgTSQuery (unpack q))
    restrict -< (_ns_typename n) .== (pgInt4 $ nodeTypeId NodeDocument)
    returnA -< FacetDoc (_ns_id n) (_ns_date n) (_ns_name n) (_ns_hyperdata n) (pgBool True) (pgInt4 1)
    ......@@ -103,7 +103,7 @@ queryInCorpusWithContacts cId q _ _ _ = proc () -> do
    (docs, (corpusDoc, (docNgrams, (ngrams', (_, contacts))))) <- joinInCorpusWithContacts -< ()
    restrict -< (_ns_search docs) @@ (pgTSQuery $ unpack q )
    restrict -< (_ns_typename docs) .== (pgInt4 $ nodeTypeId NodeDocument)
    restrict -< (nodeNode_node1_id corpusDoc) .== (toNullable $ pgInt4 cId)
    restrict -< (nodeNode_node1_id corpusDoc) .== (toNullable $ pgNodeId cId)
    restrict -< (nodeNgram_type docNgrams) .== (toNullable $ pgInt4 $ ngramsTypeId Authors)
    restrict -< (_node_typename contacts) .== (toNullable $ pgInt4 $ nodeTypeId NodeContact)
    -- let contact_id = ifThenElse (isNull $ _node_id contacts) (toNullable $ pgInt4 0) (_node_id contacts)
    ......
    src/Gargantext/Database/Tree.hs
    View file @ a759d5d6
    ......@@ -27,6 +27,7 @@ import Database.PostgreSQL.Simple.SqlQQ
    import Gargantext.Prelude
    import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
    import Gargantext.Database.Types.Node (NodeId)
    import Gargantext.Database.Config (fromNodeTypeId)
    import Gargantext.Database.Utils (Cmd, runPGSQuery)
    ------------------------------------------------------------------------
    ......@@ -48,8 +49,8 @@ treeError te = throwError $ _TreeError # te
    treeDB :: HasTreeError err => RootId -> Cmd err (Tree NodeTree)
    treeDB r = toTree =<< (toTreeParent <$> dbTree r)
    type RootId = Int
    type ParentId = Int
    type RootId = NodeId
    type ParentId = NodeId
    ------------------------------------------------------------------------
    toTree :: (MonadError e m, HasTreeError e)
    => Map (Maybe ParentId) [DbTreeNode] -> m (Tree NodeTree)
    ......@@ -74,9 +75,9 @@ toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
    toTreeParent :: [DbTreeNode] -> Map (Maybe ParentId) [DbTreeNode]
    toTreeParent = fromListWith (<>) . map (\n -> (dt_parentId n, [n]))
    ------------------------------------------------------------------------
    data DbTreeNode = DbTreeNode { dt_nodeId :: Int
    data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
    , dt_typeId :: Int
    , dt_parentId :: Maybe Int
    , dt_parentId :: Maybe NodeId
    , dt_name :: Text
    } deriving (Show)
    ......
    src/Gargantext/Database/Types/Node.hs
    View file @ a759d5d6
    ......@@ -18,6 +18,7 @@ Portability : POSIX
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    -- {-# LANGUAGE DuplicateRecordFields #-}
    module Gargantext.Database.Types.Node
    ......@@ -48,6 +49,7 @@ import Text.Read (read)
    import Text.Show (Show())
    import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
    import Database.PostgreSQL.Simple.FromField (FromField, fromField)
    import Servant
    import Test.QuickCheck.Arbitrary
    ......@@ -55,8 +57,45 @@ import Test.QuickCheck (elements)
    import Gargantext.Prelude
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Database.Utils
    ------------------------------------------------------------------------
    type NodeId = Int
    newtype NodeId = NodeId Int
    deriving (Show, Read, Generic, Num, Eq, Ord, Enum)
    instance ToField NodeId where
    toField (NodeId n) = toField n
    instance FromField NodeId where
    fromField = fromField'
    instance ToJSON NodeId
    instance FromJSON NodeId
    instance ToSchema NodeId
    instance FromHttpApiData NodeId where
    parseUrlPiece n = pure $ NodeId $ (read . cs) n
    instance ToParamSchema NodeId
    instance Arbitrary NodeId where
    arbitrary = NodeId <$> arbitrary
    type ParentId = NodeId
    type GraphId = NodeId
    type CorpusId = NodeId
    type ListId = NodeId
    type DocumentId = NodeId
    type DocId = DocumentId -- todo: remove this
    type RootId = NodeId
    type MasterCorpusId = NodeId
    type AnnuaireId = NodeId
    type ContactId = NodeId
    type UserId = Int
    type MasterUserId = UserId
    id2int :: NodeId -> Int
    id2int (NodeId n) = n
    type UTCTime' = UTCTime
    ......@@ -328,12 +367,10 @@ instance Hyperdata HyperdataNotebook
    -- | NodePoly indicates that Node has a Polymorphism Type
    type Node json = NodePoly NodeId NodeTypeId NodeUserId (Maybe NodeParentId) NodeName UTCTime json
    type Node json = NodePoly NodeId NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json
    -- type Node json = NodePoly NodeId NodeTypeId UserId ParentId NodeName UTCTime json
    type NodeTypeId = Int
    type NodeParentId = Int
    type NodeUserId = Int
    type NodeName = Text
    type TSVector = Text
    ......@@ -416,16 +453,16 @@ 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)
    type NodeSearch json = NodePolySearch NodeId NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json (Maybe TSVector)
    ------------------------------------------------------------------------
    instance (Arbitrary hyperdata
    ,Arbitrary nodeId
    ,Arbitrary nodeTypeId
    ,Arbitrary nodeUserId
    ,Arbitrary userId
    ,Arbitrary nodeParentId
    ) => Arbitrary (NodePoly nodeId nodeTypeId nodeUserId nodeParentId
    ) => Arbitrary (NodePoly nodeId nodeTypeId userId nodeParentId
    NodeName UTCTime hyperdata) where
    --arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
    arbitrary = Node <$> arbitrary <*> arbitrary <*> arbitrary
    ......@@ -435,9 +472,9 @@ instance (Arbitrary hyperdata
    instance (Arbitrary hyperdata
    ,Arbitrary nodeId
    ,Arbitrary nodeTypeId
    ,Arbitrary nodeUserId
    ,Arbitrary userId
    ,Arbitrary nodeParentId
    ) => Arbitrary (NodePolySearch nodeId nodeTypeId nodeUserId nodeParentId
    ) => Arbitrary (NodePolySearch nodeId nodeTypeId userId 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
    ......@@ -484,30 +521,30 @@ instance ToSchema HyperdataAny where
    instance ToSchema hyperdata =>
    ToSchema (NodePoly NodeId NodeTypeId
    (Maybe NodeUserId)
    NodeParentId NodeName
    (Maybe UserId)
    ParentId NodeName
    UTCTime hyperdata
    )
    instance ToSchema hyperdata =>
    ToSchema (NodePoly NodeId NodeTypeId
    NodeUserId
    (Maybe NodeParentId) NodeName
    UserId
    (Maybe ParentId) NodeName
    UTCTime hyperdata
    )
    instance ToSchema hyperdata =>
    ToSchema (NodePolySearch NodeId NodeTypeId
    (Maybe NodeUserId)
    NodeParentId NodeName
    (Maybe UserId)
    ParentId NodeName
    UTCTime hyperdata (Maybe TSVector)
    )
    instance ToSchema hyperdata =>
    ToSchema (NodePolySearch NodeId NodeTypeId
    NodeUserId
    (Maybe NodeParentId) NodeName
    UserId
    (Maybe ParentId) NodeName
    UTCTime hyperdata (Maybe TSVector)
    )
    ......
    src/Gargantext/Database/Utils.hs
    View file @ a759d5d6
    ......@@ -129,4 +129,3 @@ fromField' field mb = do
    printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
    printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
    src/Gargantext/Viz/Graph.hs
    View file @ a759d5d6
    ......@@ -38,6 +38,7 @@ import Data.Swagger
    import Gargantext.Prelude
    import Gargantext.Core.Types (Label)
    import Gargantext.Core.Utils.Prefix (unPrefix)
    import Gargantext.Database.Types.Node (NodeId)
    import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
    ......@@ -98,7 +99,7 @@ instance ToSchema LegendField where
    makeLenses ''LegendField
    --
    data GraphMetadata = GraphMetadata { _gm_title :: Text -- title of the graph
    , _gm_corpusId :: [Int] -- we can map with different corpus
    , _gm_corpusId :: [NodeId] -- we can map with different corpus
    , _gm_legend :: [LegendField] -- legend of the Graph
    }
    deriving (Show, Generic)
    ......@@ -154,8 +155,7 @@ data EdgeV3 = EdgeV3 { eo_s :: Int
    deriving (Show, Generic)
    $(deriveJSON (unPrefix "eo_") ''EdgeV3)
    data GraphV3 = GraphV3 {
    go_links :: [EdgeV3]
    data GraphV3 = GraphV3 { go_links :: [EdgeV3]
    , go_nodes :: [NodeV3]
    }
    deriving (Show, Generic)
    ......
    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