Skip to content

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

[DB|Query] clean Root funs

parent 775d6dc2
Hide whitespace changes
Inline Side-by-side
Showing with 114 additions and 99 deletions
src/Gargantext/Core/Types/Main.hs
View file @ 30386057
......@@ -39,6 +39,7 @@ import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import Text.Read (read)
type CorpusName = Text
------------------------------------------------------------------------
data NodeTree = NodeTree { _nt_name :: Text
, _nt_type :: NodeType
......@@ -74,7 +75,7 @@ type ListTypeId = Int
listTypeId :: ListType -> ListTypeId
listTypeId StopTerm = 0
listTypeId CandidateTerm = 1
listTypeId GraphTerm = 2
listTypeId GraphTerm = 2
fromListTypeId :: ListTypeId -> Maybe ListType
fromListTypeId i = lookup i $ fromList [ (listTypeId l, l) | l <- [minBound..maxBound]]
......@@ -95,7 +96,7 @@ type Offset = Int
type IsTrash = Bool
------------------------------------------------------------------------
-- All the Database is structred like a hierarchical Tree
-- All the Database is structured as a hierarchical Tree
data Tree a = TreeN { _tn_node :: a, _tn_children :: [Tree a] }
deriving (Show, Read, Eq, Generic, Ord)
......
src/Gargantext/Database/Action/Flow.hs
View file @ 30386057
......@@ -50,20 +50,19 @@ import Data.Tuple.Extra (first, second)
import Debug.Trace (trace)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Flow.Types
import Gargantext.Core.Types (NodePoly(..), Terms(..))
import Gargantext.Core.Types (Terms(..))
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Main
import Gargantext.Database.Action.Flow.List
import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Flow.Utils (insertDocNgrams, getUserId)
import Gargantext.Database.Action.Flow.Utils (insertDocNgrams)
import Gargantext.Database.Action.Query.Node
import Gargantext.Database.Action.Query.Node.Contact -- (HyperdataContact(..), ContactWho(..))
import Gargantext.Database.Action.Query.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
import Gargantext.Database.Action.Query.Tree.Root (getRoot)
import Gargantext.Database.Action.Query.Tree (mkRoot)
import Gargantext.Database.Action.Query.Tree.Root (getOrMkRoot, getOrMk_RootWithCorpus)
import Gargantext.Database.Action.Search (searchInDatabase)
import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
import Gargantext.Database.Admin.Types.Errors (HasNodeError(..), NodeError(..), nodeError)
import Gargantext.Database.Admin.Types.Errors (HasNodeError(..))
import Gargantext.Database.Admin.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
import Gargantext.Database.Admin.Utils (Cmd)
import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams, NgramsType(..), text2ngrams, ngramsTypeId)
......@@ -311,54 +310,6 @@ withLang (Unsupervised l n s m) ns = Unsupervised l n s m'
withLang l _ = l
type CorpusName = Text
getOrMkRoot :: (HasNodeError err)
=> User
-> Cmd err (UserId, RootId)
getOrMkRoot user = do
userId <- getUserId user
rootId' <- map _node_id <$> getRoot user
rootId'' <- case rootId' of
[] -> mkRoot user
n -> case length n >= 2 of
True -> nodeError ManyNodeUsers
False -> pure rootId'
rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
pure (userId, rootId)
getOrMk_RootWithCorpus :: (HasNodeError err, MkCorpus a)
=> User
-> Either CorpusName [CorpusId]
-> Maybe a
-> Cmd err (UserId, RootId, CorpusId)
getOrMk_RootWithCorpus user cName c = do
(userId, rootId) <- getOrMkRoot user
corpusId'' <- if user == UserName userMaster
then do
ns <- getCorporaWithParentId rootId
pure $ map _node_id ns
else
pure $ fromRight [] cName
corpusId' <- if corpusId'' /= []
then pure corpusId''
else do
c' <- mk (Just $ fromLeft "Default" cName) c rootId userId
_tId <- case head c' of
Nothing -> pure [0]
Just c'' -> mkNode NodeTexts c'' userId
pure c'
corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
pure (userId, rootId, corpusId)
------------------------------------------------------------------------
viewUniqId' :: UniqId a
=> a
......
src/Gargantext/Database/Action/Query/Tree.hs
View file @ 30386057
......@@ -27,46 +27,13 @@ import Data.Map (Map, fromListWith, lookup)
import Data.Text (Text)
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.SqlQQ
import Gargantext.Core.Types.Individu
import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
import Gargantext.Database.Admin.Types.Node -- (pgNodeId, NodeType(..))
import Gargantext.Database.Action.Query
import Gargantext.Database.Action.Flow.Utils (getUserId)
import Gargantext.Database.Admin.Config (fromNodeTypeId, nodeTypeId)
import Gargantext.Database.Admin.Types.Errors
import Gargantext.Database.Admin.Types.Node (NodeId, NodeType, DocId, allNodeTypes)
import Gargantext.Database.Admin.Utils (Cmd, runPGSQuery)
import Gargantext.Prelude
------------------------------------------------------------------------
-- import Gargantext.Database.Utils (runCmdDev)
-- treeTest :: IO (Tree NodeTree)
-- treeTest = runCmdDev $ treeDB 347474
------------------------------------------------------------------------
mkRoot :: HasNodeError err
=> User
-> Cmd err [RootId]
mkRoot user = do
uid <- getUserId user
let una = "username"
case uid > 0 of
False -> nodeError NegativeId
True -> do
rs <- mkNodeWithParent NodeUser Nothing uid una
_ <- case rs of
[r] -> do
_ <- mkNodeWithParent NodeFolderPrivate (Just r) uid una
_ <- mkNodeWithParent NodeFolderShared (Just r) uid una
_ <- mkNodeWithParent NodeFolderPublic (Just r) uid una
pure rs
_ -> pure rs
pure rs
------------------------------------------------------------------------
data TreeError = NoRoot | EmptyRoot | TooManyRoots
deriving (Show)
......@@ -74,16 +41,24 @@ data TreeError = NoRoot | EmptyRoot | TooManyRoots
class HasTreeError e where
_TreeError :: Prism' e TreeError
treeError :: (MonadError e m, HasTreeError e) => TreeError -> m a
treeError :: ( MonadError e m
, HasTreeError e)
=> TreeError
-> m a
treeError te = throwError $ _TreeError # te
-- | Returns the Tree of Nodes in Database
treeDB :: HasTreeError err => RootId -> [NodeType] -> Cmd err (Tree NodeTree)
treeDB :: HasTreeError err
=> RootId
-> [NodeType]
-> Cmd err (Tree NodeTree)
treeDB r nodeTypes = toTree =<< (toTreeParent <$> dbTree r nodeTypes)
------------------------------------------------------------------------
toTree :: (MonadError e m, HasTreeError e)
=> Map (Maybe ParentId) [DbTreeNode] -> m (Tree NodeTree)
toTree :: ( MonadError e m
, HasTreeError e)
=> Map (Maybe ParentId) [DbTreeNode]
-> m (Tree NodeTree)
toTree m =
case lookup Nothing m of
Just [n] -> pure $ toTree' m n
......@@ -91,18 +66,22 @@ toTree m =
Just [] -> treeError EmptyRoot
Just _ -> treeError TooManyRoots
toTree' :: Map (Maybe ParentId) [DbTreeNode] -> DbTreeNode -> Tree NodeTree
toTree' :: Map (Maybe ParentId) [DbTreeNode]
-> DbTreeNode
-> Tree NodeTree
toTree' m n =
TreeN (toNodeTree n) $
m ^.. at (Just $ dt_nodeId n) . _Just . each . to (toTree' m)
------------------------------------------------------------------------
toNodeTree :: DbTreeNode -> NodeTree
toNodeTree :: DbTreeNode
-> NodeTree
toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
where
nodeType = fromNodeTypeId tId
------------------------------------------------------------------------
toTreeParent :: [DbTreeNode] -> Map (Maybe ParentId) [DbTreeNode]
toTreeParent :: [DbTreeNode]
-> Map (Maybe ParentId) [DbTreeNode]
toTreeParent = fromListWith (<>) . map (\n -> (dt_parentId n, [n]))
------------------------------------------------------------------------
data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
......@@ -113,7 +92,9 @@ data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
-- | Main DB Tree function
-- TODO add typenames as parameters
dbTree :: RootId -> [NodeType] -> Cmd err [DbTreeNode]
dbTree :: RootId
-> [NodeType]
-> Cmd err [DbTreeNode]
dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
<$> runPGSQuery [sql|
WITH RECURSIVE
......
src/Gargantext/Database/Action/Query/Tree/Root.hs
View file @ 30386057
......@@ -27,12 +27,19 @@ Portability : POSIX
module Gargantext.Database.Action.Query.Tree.Root
where
import Data.Either (Either, fromLeft, fromRight)
import Control.Arrow (returnA)
import Gargantext.Core.Types.Main (CorpusName)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Config (nodeTypeId, userMaster)
import Gargantext.Database.Admin.Types.Errors
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Action.Query.Node
import Gargantext.Database.Action.Query.Node.User (HyperdataUser)
import Gargantext.Database.Action.Flow.Utils (getUserId)
import Gargantext.Database.Schema.Node (NodeRead)
import Gargantext.Database.Schema.Node (queryNodeTable)
import Gargantext.Database.Action.Query
import Gargantext.Database.Schema.User (UserPoly(..))
import Gargantext.Database.Action.Query.User (queryUserTable)
import Gargantext.Database.Admin.Types.Node (Node, NodePoly(..), NodeType(NodeUser), pgNodeId)
......@@ -41,6 +48,83 @@ import Gargantext.Prelude
import Opaleye (restrict, (.==), Query)
import Opaleye.PGTypes (pgStrictText, pgInt4)
getOrMkRoot :: (HasNodeError err)
=> User
-> Cmd err (UserId, RootId)
getOrMkRoot user = do
userId <- getUserId user
rootId' <- map _node_id <$> getRoot user
rootId'' <- case rootId' of
[] -> mkRoot user
n -> case length n >= 2 of
True -> nodeError ManyNodeUsers
False -> pure rootId'
rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
pure (userId, rootId)
getOrMk_RootWithCorpus :: (HasNodeError err, MkCorpus a)
=> User
-> Either CorpusName [CorpusId]
-> Maybe a
-> Cmd err (UserId, RootId, CorpusId)
getOrMk_RootWithCorpus user cName c = do
(userId, rootId) <- getOrMkRoot user
corpusId'' <- if user == UserName userMaster
then do
ns <- getCorporaWithParentId rootId
pure $ map _node_id ns
else
pure $ fromRight [] cName
corpusId' <- if corpusId'' /= []
then pure corpusId''
else do
c' <- mk (Just $ fromLeft "Default" cName) c rootId userId
_tId <- case head c' of
Nothing -> pure [0]
Just c'' -> mkNode NodeTexts c'' userId
pure c'
corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
pure (userId, rootId, corpusId)
mkRoot :: HasNodeError err
=> User
-> Cmd err [RootId]
mkRoot user = do
-- TODO
-- udb <- getUserDb user
-- let uid = user_id udb
uid <- getUserId user
-- TODO ? Which name for user Node ?
let una = "username"
case uid > 0 of
False -> nodeError NegativeId
True -> do
rs <- mkNodeWithParent NodeUser Nothing uid una
_ <- case rs of
[r] -> do
_ <- mkNodeWithParent NodeFolderPrivate (Just r) uid una
_ <- mkNodeWithParent NodeFolderShared (Just r) uid una
_ <- mkNodeWithParent NodeFolderPublic (Just r) uid una
pure rs
_ -> pure rs
pure rs
getRoot :: User -> Cmd err [Node HyperdataUser]
getRoot = runOpaQuery . selectRoot
......@@ -66,5 +150,3 @@ selectRoot (RootId nid) =
restrict -< _node_id row .== (pgNodeId nid)
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