Skip to content

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

[WIP/DB] Refactoring (start).

parent b7355306
Hide whitespace changes
Inline Side-by-side
Showing with 349 additions and 362 deletions
src/Gargantext/Database/Flow.hs → src/Gargantext/Database/Action/Flow.hs
View file @ 942a2832
......@@ -27,7 +27,7 @@ Portability : POSIX
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
( FlowCmdM
, flowCorpusFile
, flowCorpus
......
src/Gargantext/Database/Flow/Annuaire.hs → src/Gargantext/Database/Action/Flow/Annuaire.hs
View file @ 942a2832
......@@ -16,11 +16,10 @@ Portability : POSIX
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
module Gargantext.Database.Flow.Annuaire
module Gargantext.Database.Action.Flow.Annuaire
where
{-
import Gargantext.Prelude
import Gargantext.Database.Flow
......
src/Gargantext/Database/Flow/List.hs → src/Gargantext/Database/Action/Flow/List.hs
View file @ 942a2832
......@@ -21,7 +21,7 @@ Portability : POSIX
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Database.Flow.List
module Gargantext.Database.Action.Flow.List
where
import Data.Text (Text)
import Control.Monad (mapM_)
......
src/Gargantext/Database/Flow/Pairing.hs → src/Gargantext/Database/Action/Flow/Pairing.hs
View file @ 942a2832
......@@ -16,7 +16,7 @@ Portability : POSIX
{-# LANGUAGE RankNTypes #-}
-- {-# LANGUAGE Arrows #-}
module Gargantext.Database.Flow.Pairing
module Gargantext.Database.Action.Flow.Pairing
(pairing)
where
......
src/Gargantext/Database/Flow/Types.hs → src/Gargantext/Database/Action/Flow/Types.hs
View file @ 942a2832
......@@ -21,7 +21,7 @@ Portability : POSIX
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Database.Flow.Types
module Gargantext.Database.Action.Flow.Types
where
import Data.Map (Map)
......
src/Gargantext/Database/Flow/Utils.hs → src/Gargantext/Database/Action/Flow/Utils.hs
View file @ 942a2832
......@@ -14,7 +14,7 @@ Portability : POSIX
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Flow.Utils
module Gargantext.Database.Action.Flow.Utils
where
import Data.Map (Map)
......
src/Gargantext/Database/Learn.hs → src/Gargantext/Database/Action/Learn.hs
View file @ 942a2832
......@@ -16,7 +16,8 @@ Portability : POSIX
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
module Gargantext.Database.Learn where
module Gargantext.Database.Action.Learn
where
import Data.Text (Text)
import Data.Tuple (snd)
......
src/Gargantext/Database/Metrics.hs → src/Gargantext/Database/Action/Metrics.hs
View file @ 942a2832
......@@ -15,7 +15,7 @@ Node API
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
module Gargantext.Database.Metrics
module Gargantext.Database.Action.Metrics
where
import Data.Map (Map)
......
src/Gargantext/Database/Lists.hs → src/Gargantext/Database/Action/Metrics/Lists.hs
View file @ 942a2832
......@@ -23,7 +23,8 @@ Portability : POSIX
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Lists where
module Gargantext.Database.Action.Metrics.Lists
where
import Gargantext.API.Ngrams (TabType(..))
import Gargantext.Core.Types -- (NodePoly(..), NodeCorpus, ListId)
......
src/Gargantext/Database/Metrics/NgramsByNode.hs → src/Gargantext/Database/Action/Metrics/NgramsByNode.hs
View file @ 942a2832
......@@ -17,7 +17,7 @@ Ngrams by node enable contextual metrics.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Metrics.NgramsByNode
module Gargantext.Database.Action.Metrics.NgramsByNode
where
import Debug.Trace (trace)
......
src/Gargantext/Database/TextSearch.hs → src/Gargantext/Database/Action/Search.hs
View file @ 942a2832
......@@ -14,7 +14,7 @@ Portability : POSIX
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.TextSearch where
module Gargantext.Database.Action.Search where
import Data.Aeson
import Data.Map.Strict hiding (map, drop, take)
......@@ -35,7 +35,7 @@ import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.NodeNode hiding (joinInCorpus)
import Gargantext.Database.Schema.NodeNodeNgrams
import Gargantext.Database.Queries.Join (leftJoin6)
import Gargantext.Database.Query.Join (leftJoin6)
import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery, runCountOpaQuery)
import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
import Gargantext.Core.Types
......
src/Gargantext/Database/Access.hs → src/Gargantext/Database/Admin/Access.hs
View file @ 942a2832
......@@ -13,8 +13,7 @@ TODO-SECURITY review purpose of this module
{-# LANGUAGE NoImplicitPrelude #-}
module Gargantext.Database.Access where
module Gargantext.Database.Admin.Access where
data Action = Read | Write | Exec
data Roles = RoleUser | RoleMaster
......
src/Gargantext/Database/Bashql.hs → src/Gargantext/Database/Admin/Bashql.hs
View file @ 942a2832
......@@ -64,7 +64,7 @@ TODO-ACCESS: should the checks be done here or before.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Bashql () {-( get
module Gargantext.Database.Admin.Bashql () {-( get
, ls
, home
, post
......
src/Gargantext/Database/Config.hs → src/Gargantext/Database/Admin/Config.hs
View file @ 942a2832
......@@ -16,7 +16,7 @@ TODO: configure nodes table in Haskell (Config typenames etc.)
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Database.Config
module Gargantext.Database.Admin.Config
where
......
src/Gargantext/Database/Schema/Ngrams.hs → src/Gargantext/Database/Admin/Schema/Ngrams.hs
View file @ 942a2832
......@@ -24,7 +24,7 @@ Ngrams connection to the Database.
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.Ngrams where
module Gargantext.Database.Admin.Schema.Ngrams where
import Control.Lens (makeLenses, over)
import Control.Monad (mzero)
......
src/Gargantext/Database/Schema/Node.hs → src/Gargantext/Database/Admin/Schema/Node.hs
View file @ 942a2832
......@@ -39,9 +39,7 @@ import Gargantext.Core.Types
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Node.Contact (HyperdataContact(..), arbitraryHyperdataContact)
import Gargantext.Database.Node.User (HyperdataUser(..), fake_HyperdataUser)
import Gargantext.Database.Queries.Filter (limit', offset')
import Gargantext.Database.Schema.User (getUserId)
import Gargantext.Database.Query.Filter (limit', offset')
import Gargantext.Database.Types.Errors
import Gargantext.Database.Types.Node (NodeType(..), defaultCorpus, Hyperdata, HyperData(..))
import Gargantext.Database.Utils
......@@ -251,500 +249,3 @@ nodeTableSearch = Table "nodes" (pNodeSearch NodeSearch { _ns_id = optio
)
queryNodeSearchTable :: Query NodeSearchRead
queryNodeSearchTable = queryTable nodeTableSearch
selectNode :: Column PGInt4 -> Query NodeRead
selectNode id = proc () -> do
row <- queryNodeTable -< ()
restrict -< _node_id row .== id
returnA -< row
runGetNodes :: Query NodeRead -> Cmd err [Node HyperdataAny]
runGetNodes = runOpaQuery
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | order by publication date
-- Favorites (Bool), node_ngrams
selectNodesWith :: ParentId -> Maybe NodeType
-> Maybe Offset -> Maybe Limit -> Query NodeRead
selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
--offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
limit' maybeLimit $ offset' maybeOffset
$ orderBy (asc _node_id)
$ selectNodesWith' parentId maybeNodeType
selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' parentId maybeNodeType = proc () -> do
node <- (proc () -> do
row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
restrict -< parentId' .== (pgNodeId parentId)
let typeId' = maybe 0 nodeTypeId maybeNodeType
restrict -< if typeId' > 0
then typeId .== (pgInt4 (typeId' :: Int))
else (pgBool True)
returnA -< row ) -< ()
returnA -< node
deleteNode :: NodeId -> Cmd err Int
deleteNode n = mkCmd $ \conn ->
fromIntegral <$> runDelete conn nodeTable
(\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
deleteNodes :: [NodeId] -> Cmd err Int
deleteNodes ns = mkCmd $ \conn ->
fromIntegral <$> runDelete conn nodeTable
(\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
-- TODO: NodeType should match with `a'
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 :: (Hyperdata a, QueryRunnerColumnDefault PGJsonb a)
=> Maybe NodeId
-> Cmd err [Node a]
getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
where
n' = case n of
Just n'' -> n''
Nothing -> 0
------------------------------------------------------------------------
getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
-- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataListModel]
getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeListModel)
getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
------------------------------------------------------------------------
selectNodesWithParentID :: NodeId -> Query NodeRead
selectNodesWithParentID n = proc () -> do
row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
restrict -< parent_id .== (pgNodeId n)
returnA -< row
selectNodesWithType :: Column PGInt4 -> Query NodeRead
selectNodesWithType type_id = proc () -> do
row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
restrict -< tn .== type_id
returnA -< row
type JSONB = QueryRunnerColumnDefault PGJsonb
getNode :: NodeId -> Cmd err (Node Value)
getNode nId = fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
getNodeWith :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
getNodeWith nId _ = do
fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
getNodeUser :: NodeId -> Cmd err (Node HyperdataUser)
getNodeUser nId = do
fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
getNodePhylo :: NodeId -> Cmd err (Node HyperdataPhylo)
getNodePhylo nId = do
fromMaybe (error $ "Node Phylo does not exist: " <> show nId) . headMay
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
getNodesWithType = runOpaQuery . selectNodesWithType
------------------------------------------------------------------------
nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
where
name = maybe "User" identity maybeName
user = maybe fake_HyperdataUser identity maybeHyperdata
nodeContactW :: Maybe Name -> Maybe HyperdataContact
-> AnnuaireId -> UserId -> NodeWrite
nodeContactW maybeName maybeContact aId =
node NodeContact name contact (Just aId)
where
name = maybe "Contact" identity maybeName
contact = maybe arbitraryHyperdataContact identity maybeContact
------------------------------------------------------------------------
defaultFolder :: HyperdataCorpus
defaultFolder = defaultCorpus
nodeFolderW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
where
name = maybe "Folder" identity maybeName
folder = maybe defaultFolder identity maybeFolder
------------------------------------------------------------------------
nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
where
name = maybe "Corpus" identity maybeName
corpus = maybe defaultCorpus identity maybeCorpus
--------------------------
defaultDocument :: HyperdataDocument
defaultDocument = hyperdataDocument
nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
where
name = maybe "Document" identity maybeName
doc = maybe defaultDocument identity maybeDocument
------------------------------------------------------------------------
defaultAnnuaire :: HyperdataAnnuaire
defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
where
name = maybe "Annuaire" identity maybeName
annuaire = maybe defaultAnnuaire identity maybeAnnuaire
------------------------------------------------------------------------
{-
class IsNodeDb a where
data Node'' a :: *
data Hyper a :: *
instance IsNodeDb NodeType where
data
instance HasHyperdata NodeType where
data Hyper NodeType = HyperList HyperdataList
| HyperCorpus HyperdataCorpus
hasHyperdata nt = case nt of
NodeList -> HyperList $ HyperdataList (Just "list")
unHyper h = case h of
HyperList h' -> h'
--}
class HasDefault a where
hasDefaultData :: a -> HyperData
hasDefaultName :: a -> Text
instance HasDefault NodeType where
hasDefaultData nt = case nt of
NodeTexts -> HyperdataTexts (Just "Preferences")
NodeList -> HyperdataList' (Just "Preferences")
NodeListCooc -> HyperdataList' (Just "Preferences")
_ -> undefined
--NodeAnnuaire -> HyperdataAnnuaire (Just "Title") (Just "Description")
hasDefaultName nt = case nt of
NodeTexts -> "Texts"
NodeList -> "Lists"
NodeListCooc -> "Cooc"
_ -> undefined
------------------------------------------------------------------------
nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
nodeDefault nt parent = node nt name hyper (Just parent)
where
name = (hasDefaultName nt)
hyper = (hasDefaultData nt)
------------------------------------------------------------------------
arbitraryListModel :: HyperdataListModel
arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
where
name = maybe "List Model" identity maybeName
list = maybe arbitraryListModel identity maybeListModel
------------------------------------------------------------------------
arbitraryGraph :: HyperdataGraph
arbitraryGraph = HyperdataGraph Nothing
nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
where
name = maybe "Graph" identity maybeName
graph = maybe arbitraryGraph identity maybeGraph
mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
------------------------------------------------------------------------
arbitraryPhylo :: HyperdataPhylo
arbitraryPhylo = HyperdataPhylo Nothing Nothing
nodePhyloW :: Maybe Name -> Maybe HyperdataPhylo -> ParentId -> UserId -> NodeWrite
nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
where
name = maybe "Phylo" identity maybeName
graph = maybe arbitraryPhylo identity maybePhylo
------------------------------------------------------------------------
arbitraryDashboard :: HyperdataDashboard
arbitraryDashboard = HyperdataDashboard (Just "Preferences") []
------------------------------------------------------------------------
node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
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
-------------------------------
insertNodes :: [NodeWrite] -> Cmd err Int64
insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
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 (pgNodeId <$> 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
{- TODO semantic to achieve
post c uid pid [ Node' NodeCorpus "name" "{}" []
, Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
, Node' NodeDocument "title" "jsonData" []
]
]
]
-}
------------------------------------------------------------------------
-- TODO
-- 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 pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
data Node' = Node' { _n_type :: NodeType
, _n_name :: Text
, _n_data :: Value
, _n_children :: [Node']
} deriving (Show)
mkNodes :: [NodeWrite] -> Cmd err Int64
mkNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
------------------------------------------------------------------------
data NewNode = NewNode { _newNodeId :: NodeId
, _newNodeChildren :: [NodeId] }
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' []
_ -> nodeError ManyParents
postNode uid pid (Node' NodeCorpus txt v ns) = do
NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
pids <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
pure $ NewNode pid' pids
postNode uid pid (Node' NodeAnnuaire txt v ns) = do
NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
pids <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
pure $ NewNode pid' pids
postNode uid pid (Node' NodeDashboard txt v ns) = do
NewNode pid' _ <- postNode uid pid (Node' NodeDashboard txt v [])
pids <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
pure $ NewNode pid' pids
postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
childWith :: UserId -> ParentId -> Node' -> NodeWrite
childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
childWith uId pId (Node' NodeContact txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a child"
-- =================================================================== --
------------------------------------------------------------------------
-- | TODO mk all others nodes
mkNodeWithParent :: HasNodeError err
=> NodeType
-> Maybe ParentId
-> UserId
-> Name
-> Cmd err [NodeId]
mkNodeWithParent NodeUser (Just _) _ _ = nodeError UserNoParent
------------------------------------------------------------------------
mkNodeWithParent NodeUser Nothing uId name =
insertNodesWithParentR Nothing [node NodeUser name fake_HyperdataUser Nothing uId]
mkNodeWithParent _ Nothing _ _ = nodeError HasParent
------------------------------------------------------------------------
mkNodeWithParent NodeFolder (Just i) uId name =
insertNodesWithParentR (Just i) [node NodeFolder name hd Nothing uId]
where
hd = defaultFolder
mkNodeWithParent NodeFolderPrivate (Just i) uId _ =
insertNodesWithParentR (Just i) [node NodeFolderPrivate "Private" hd Nothing uId]
where
hd = defaultFolder
mkNodeWithParent NodeFolderShared (Just i) uId _ =
insertNodesWithParentR (Just i) [node NodeFolderShared "Shared" hd Nothing uId]
where
hd = defaultFolder
mkNodeWithParent NodeFolderPublic (Just i) uId _ =
insertNodesWithParentR (Just i) [node NodeFolderPublic "Public" hd Nothing uId]
where
hd = defaultFolder
mkNodeWithParent NodeTeam (Just i) uId _ =
insertNodesWithParentR (Just i) [node NodeTeam "Team" hd Nothing uId]
where
hd = defaultFolder
------------------------------------------------------------------------
mkNodeWithParent NodeCorpus (Just i) uId name =
insertNodesWithParentR (Just i) [node NodeCorpus name hd Nothing uId]
where
hd = defaultCorpus
mkNodeWithParent NodeAnnuaire (Just i) uId name =
insertNodesWithParentR (Just i) [node NodeAnnuaire name hd Nothing uId]
where
hd = defaultAnnuaire
mkNodeWithParent _ _ _ _ = nodeError NotImplYet
------------------------------------------------------------------------
-- =================================================================== --
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
-- |
-- CorpusDocument is a corpus made from a set of documents
-- CorpusContact is a corpus made from a set of contacts (syn of Annuaire)
data CorpusType = CorpusDocument | CorpusContact
class MkCorpus a
where
mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
instance MkCorpus HyperdataCorpus
where
mk n h p u = insertNodesR [nodeCorpusW n h p u]
instance MkCorpus HyperdataAnnuaire
where
mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
getOrMkList pId uId =
maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
where
mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkNode NodeList pId uId
-- | TODO remove defaultList
defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
defaultList cId =
maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
mkNode nt p u = insertNodesR [nodeDefault nt p u]
mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
where
nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
where
name = maybe "Board" identity maybeName
dashboard = maybe arbitraryDashboard identity maybeDashboard
mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
-- | Default CorpusId Master and ListId Master
pgNodeId :: NodeId -> Column PGInt4
pgNodeId = pgInt4 . id2int
getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
-- import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
-- updateNodeUser_fake :: NodeId -> Cmd err Int64
-- updateNodeUser_fake n = updateHyperdata n fake_HyperdataUser
src/Gargantext/Database/Schema/NodeNgrams.hs → src/Gargantext/Database/Admin/Schema/NodeNgrams.hs
View file @ 942a2832
......@@ -25,7 +25,7 @@ NodeNgrams register Context of Ngrams (named Cgrams then)
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.NodeNgrams where
module Gargantext.Database.Admin.Schema.NodeNgrams where
import Data.Map (Map)
import qualified Data.Map as Map
......
src/Gargantext/Database/Schema/NodeNode.hs → src/Gargantext/Database/Admin/Schema/NodeNode.hs
View file @ 942a2832
......@@ -24,7 +24,7 @@ commentary with @some markup@.
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.NodeNode where
module Gargantext.Database.Admin.Schema.NodeNode where
import Control.Lens (view, (^.))
import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
......@@ -34,7 +34,7 @@ import Control.Lens.TH (makeLenses)
import Data.Maybe (Maybe, catMaybes)
import Data.Text (Text, splitOn)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Gargantext.Database.Schema.Node
import Gargantext.Database.Tools.Node (pgNodeId)
import Gargantext.Core.Types
import Gargantext.Database.Utils
import Gargantext.Database.Config (nodeTypeId)
......
src/Gargantext/Database/Schema/NodeNodeNgrams.hs → src/Gargantext/Database/Admin/Schema/NodeNodeNgrams.hs
View file @ 942a2832
......@@ -20,7 +20,7 @@ Portability : POSIX
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.NodeNodeNgrams
module Gargantext.Database.Admin.Schema.NodeNodeNgrams
where
import Prelude
......@@ -28,7 +28,7 @@ import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Control.Lens.TH (makeLenses)
import Gargantext.Database.Utils (Cmd, mkCmd)
import Gargantext.Database.Schema.Ngrams (NgramsTypeId, pgNgramsTypeId, NgramsId)
import Gargantext.Database.Schema.Node (pgNodeId)
import Gargantext.Database.Tools.Node (pgNodeId)
import Gargantext.Database.Types.Node
import Opaleye
......
src/Gargantext/Database/Schema/NodeNodeNgrams2.hs → src/Gargantext/Database/Admin/Schema/NodeNodeNgrams2.hs
View file @ 942a2832
......@@ -20,7 +20,7 @@ Portability : POSIX
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.NodeNodeNgrams2
module Gargantext.Database.Admin.Schema.NodeNodeNgrams2
where
import Prelude
......@@ -28,7 +28,7 @@ import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Control.Lens.TH (makeLenses)
import Gargantext.Database.Utils (Cmd, mkCmd)
import Gargantext.Database.Schema.NodeNgrams (NodeNgramsId)
import Gargantext.Database.Schema.Node (pgNodeId)
import Gargantext.Database.Tools.Node (pgNodeId)
import Gargantext.Database.Types.Node
import Opaleye
......
src/Gargantext/Database/Schema/Node_NodeNgramsNodeNgrams.hs → src/Gargantext/Database/Admin/Schema/Node_NodeNgramsNodeNgrams.hs
View file @ 942a2832
......@@ -33,7 +33,7 @@ Next Step benchmark:
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Database.Schema.Node_NodeNgramsNodeNgrams
module Gargantext.Database.Admin.Schema.Node_NodeNgramsNodeNgrams
where
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
......@@ -41,7 +41,7 @@ import Data.Maybe (Maybe)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Gargantext.Database.Utils (Cmd, runOpaQuery, mkCmd)
import Gargantext.Database.Types.Node (CorpusId)
import Gargantext.Database.Schema.Node (pgNodeId)
import Gargantext.Database.Tools.Node (pgNodeId)
import Gargantext.Prelude
import Opaleye
......
src/Gargantext/Database/Schema/NodesNgramsRepo.hs → src/Gargantext/Database/Admin/Schema/NodesNgramsRepo.hs
View file @ 942a2832
......@@ -25,7 +25,8 @@ Portability : POSIX
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.NodesNgramsRepo where
module Gargantext.Database.Admin.Schema.NodesNgramsRepo
where
import Control.Arrow (returnA)
import Control.Lens.TH (makeLenses)
......
src/Gargantext/Database/Schema/User.hs → src/Gargantext/Database/Admin/Schema/User.hs
View file @ 942a2832
......@@ -23,7 +23,7 @@ Functions to deal with users, database side.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Schema.User where
module Gargantext.Database.Admin.Schema.User where
import Control.Arrow (returnA)
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
......@@ -113,79 +113,3 @@ userTable = Table "auth_user" (pUserDB UserDB { user_id = optional "id"
}
)
-- TODO: on conflict, nice message
insertUsers :: [UserWrite] -> Cmd err Int64
insertUsers us = mkCmd $ \c -> runInsert_ c insert
where
insert = Insert userTable us rCount Nothing
gargantextUser :: Username -> UserWrite
gargantextUser u = UserDB (Nothing) (pgStrictText "password")
(Nothing) (pgBool True) (pgStrictText u)
(pgStrictText "first_name")
(pgStrictText "last_name")
(pgStrictText "e@mail")
(pgBool True) (pgBool True) (Nothing)
insertUsersDemo :: Cmd err Int64
insertUsersDemo = insertUsers $ map (\u -> gargantextUser u) arbitraryUsername
------------------------------------------------------------------
queryUserTable :: Query UserRead
queryUserTable = queryTable userTable
selectUsersLight :: Query UserRead
selectUsersLight = proc () -> do
row@(UserDB i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
restrict -< i .== 1
--returnA -< User i p ll is un fn ln m iff ive dj
returnA -< row
------------------------------------------------------------------
-- | Select User with some parameters
-- Not optimized version
userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
userWith f t xs = find (\x -> f x == t) xs
-- | Select User with Username
userWithUsername :: Text -> [UserDB] -> Maybe UserDB
userWithUsername t xs = userWith user_username t xs
userWithId :: Int -> [UserDB] -> Maybe UserDB
userWithId t xs = userWith user_id t xs
userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
userLightWithUsername t xs = userWith userLight_username t xs
userLightWithId :: Int -> [UserLight] -> Maybe UserLight
userLightWithId t xs = userWith userLight_id t xs
instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
queryRunnerColumnDefault = fieldQueryRunnerColumn
users :: Cmd err [UserDB]
users = runOpaQuery queryUserTable
usersLight :: Cmd err [UserLight]
usersLight = map toUserLight <$> users
getUser :: Username -> Cmd err (Maybe UserLight)
getUser u = userLightWithUsername u <$> usersLight
getUserId :: HasNodeError err
=> User
-> Cmd err UserId
getUserId (UserDBId uid) = pure uid
getUserId (RootId rid) = do
n <- getNode rid
pure $ _node_userId n
getUserId (UserName u ) = do
muser <- getUser u
case muser of
Just user -> pure $ userLight_id user
Nothing -> nodeError NoUserFound
src/Gargantext/Database/Init.hs → src/Gargantext/Database/Admin/Trigger/Init.hs
View file @ 942a2832
......@@ -17,7 +17,7 @@ Ngrams by node enable contextual metrics.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Init
module Gargantext.Database.Admin.Trigger.Init
where
-- import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
......
src/Gargantext/Database/Triggers/NodeNodeNgrams.hs → src/Gargantext/Database/Admin/Trigger/NodeNodeNgrams.hs
View file @ 942a2832
......@@ -17,7 +17,7 @@ Triggers on NodeNodeNgrams table.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Triggers.NodeNodeNgrams
module Gargantext.Database.Admin.Trigger.NodeNodeNgrams
where
import Database.PostgreSQL.Simple.SqlQQ (sql)
......
src/Gargantext/Database/Triggers/Nodes.hs → src/Gargantext/Database/Admin/Trigger/Nodes.hs
View file @ 942a2832
{-|
Module : Gargantext.Database.Triggers.Nodes
Module : Gargantext.Database.Admin.Trigger.Nodes
Description : Triggers configuration
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -17,7 +17,7 @@ Triggers on Nodes table.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Triggers.Nodes
module Gargantext.Database.Admin.Trigger.Nodes
where
import Database.PostgreSQL.Simple.SqlQQ (sql)
......
src/Gargantext/Database/Triggers/NodesNodes.hs → src/Gargantext/Database/Admin/Trigger/NodesNodes.hs
View file @ 942a2832
......@@ -17,7 +17,7 @@ Triggers on NodesNodes table.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Triggers.NodesNodes
module Gargantext.Database.Admin.Trigger.NodesNodes
where
import Database.PostgreSQL.Simple.SqlQQ (sql)
......
src/Gargantext/Database/Types/Node.hs → src/Gargantext/Database/Admin/Types/Node.hs
View file @ 942a2832
......@@ -22,7 +22,7 @@ Portability : POSIX
-- {-# LANGUAGE DuplicateRecordFields #-}
module Gargantext.Database.Types.Node
module Gargantext.Database.Admin.Types.Node
where
import Prelude (Enum, Bounded, minBound, maxBound)
......
src/Gargantext/Database/Utils.hs → src/Gargantext/Database/Admin/Utils.hs
View file @ 942a2832
......@@ -19,7 +19,7 @@ commentary with @some markup@.
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Utils where
module Gargantext.Database.Admin.Utils where
import Data.ByteString.Char8 (hPutStrLn)
import System.IO (stderr)
......
src/Gargantext/Database/Facet.hs → src/Gargantext/Database/Query/Facet.hs
View file @ 942a2832
......@@ -25,7 +25,7 @@ Portability : POSIX
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
------------------------------------------------------------------------
module Gargantext.Database.Facet
module Gargantext.Database.Query.Facet
( runViewAuthorsDoc
, runViewDocuments
, filterWith
......@@ -62,8 +62,8 @@ import Gargantext.Database.Schema.NodeNode
import Gargantext.Database.Schema.NodeNodeNgrams
-- import Gargantext.Database.Schema.NodeNodeNgrams2
import Gargantext.Database.Utils
import Gargantext.Database.Queries.Filter
import Gargantext.Database.Queries.Join (leftJoin5)
import Gargantext.Database.Query.Filter
import Gargantext.Database.Query.Join (leftJoin5)
import Opaleye
import Prelude hiding (null, id, map, sum, not, read)
import Servant.API
......
src/Gargantext/Database/Queries/Filter.hs → src/Gargantext/Database/Query/Filter.hs
View file @ 942a2832
{-|
Module : Gargantext.Database.Queries.Filter
Module : Gargantext.Database.Query.Filter
Description : Main requests of Node to the database
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -19,7 +19,7 @@ Portability : POSIX
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Database.Queries.Filter where
module Gargantext.Database.Query.Filter where
import Gargantext.Core.Types (Limit, Offset)
import Data.Maybe (Maybe, maybe)
......
src/Gargantext/Database/Queries/Join.hs → src/Gargantext/Database/Query/Join.hs
View file @ 942a2832
{-|
Module : Gargantext.Database.Queries.Join
Module : Gargantext.Database.Query.Join
Description : Main Join queries (using Opaleye)
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
......@@ -26,7 +26,7 @@ Multiple Join functions with Opaleye.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
------------------------------------------------------------------------
module Gargantext.Database.Queries.Join
module Gargantext.Database.Query.Query.Join
where
------------------------------------------------------------------------
......
src/Gargantext/Database/Ngrams.hs → src/Gargantext/Database/Query/Ngrams.hs
View file @ 942a2832
......@@ -14,16 +14,16 @@ Portability : POSIX
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Ngrams
module Gargantext.Database.Query.Ngrams
where
import Data.Text (Text)
import Control.Lens ((^.))
import Gargantext.Core.Types
import Gargantext.Database.Utils (runOpaQuery, Cmd)
import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.NodeNodeNgrams
import Gargantext.Database.Schema.Node
import Gargantext.Database.Admin.Utils (runOpaQuery, Cmd)
import Gargantext.Database.Admin.Schema.Ngrams
import Gargantext.Database.Admin.Schema.NodeNodeNgrams
import Gargantext.Database.Admin.Schema.Node
import Gargantext.Prelude
import Opaleye
import Control.Arrow (returnA)
......
src/Gargantext/Database/Node/Children.hs → src/Gargantext/Database/Query/Node/Children.hs
View file @ 942a2832
......@@ -16,18 +16,18 @@ Portability : POSIX
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Node.Children where
module Gargantext.Database.Query.Node.Children where
import Data.Proxy
import Opaleye
import Gargantext.Core.Types
import Gargantext.Database.Schema.Node
import Gargantext.Database.Utils
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 Gargantext.Database.Admin.Schema.Node
import Gargantext.Database.Admin.Utils
import Gargantext.Database.Admin.Schema.NodeNode
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Query.Filter
import Gargantext.Database.Query.Node.Contact (HyperdataContact)
import Gargantext.Database.Admin.Schema.Node (pgNodeId)
import Control.Arrow (returnA)
getAllDocuments :: ParentId -> Cmd err (TableResult (Node HyperdataDocument))
......
src/Gargantext/Database/Node/Contact.hs → src/Gargantext/Database/Query/Node/Contact.hs
View file @ 942a2832
......@@ -17,7 +17,7 @@ Portability : POSIX
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Node.Contact
module Gargantext.Database.Query.Node.Contact
where
import Control.Lens (makeLenses)
......
src/Gargantext/Database/Node/Document/Add.hs → src/Gargantext/Database/Query/Node/Document/Add.hs
View file @ 942a2832
......@@ -21,9 +21,10 @@ Add Documents/Contact to a Corpus/Annuaire.
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
------------------------------------------------------------------------
module Gargantext.Database.Node.Document.Add where
------------------------------------------------------------------------
module Gargantext.Database.Query.Node.Document.Add
where
import Data.ByteString.Internal (ByteString)
import Data.Typeable (Typeable)
......
src/Gargantext/Database/Node/Document/Insert.hs → src/Gargantext/Database/Query/Node/Document/Insert.hs
View file @ 942a2832
......@@ -57,7 +57,7 @@ the concatenation of the parameters defined by @shaParameters@.
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
------------------------------------------------------------------------
module Gargantext.Database.Node.Document.Insert where
module Gargantext.Database.Query.Node.Document.Insert where
import Control.Lens (set, view)
import Control.Lens.Prism
......
src/Gargantext/Database/Node/Select.hs → src/Gargantext/Database/Query/Node/Select.hs
View file @ 942a2832
......@@ -14,7 +14,8 @@ Portability : POSIX
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Node.Select where
module Gargantext.Database.Query.Node.Select
where
import Opaleye
import Gargantext.Core.Types
......
src/Gargantext/Database/Node/Update.hs → src/Gargantext/Database/Query/Node/Update.hs
View file @ 942a2832
......@@ -16,7 +16,8 @@ Portability : POSIX
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Node.Update (Update(..), update) where
module Gargantext.Database.Query.Node.Update (Update(..), update)
where
import qualified Data.Text as DT
import Database.PostgreSQL.Simple
......
src/Gargantext/Database/Node/UpdateOpaleye.hs → src/Gargantext/Database/Query/Node/UpdateOpaleye.hs
View file @ 942a2832
......@@ -16,7 +16,7 @@ Portability : POSIX
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Node.UpdateOpaleye where
module Gargantext.Database.Query.Node.UpdateOpaleye where
import Opaleye
......
src/Gargantext/Database/Node/User.hs → src/Gargantext/Database/Query/Node/User.hs
View file @ 942a2832
......@@ -17,7 +17,7 @@ Portability : POSIX
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Node.User
module Gargantext.Database.Query.Node.User
where
import Control.Lens (makeLenses)
......@@ -31,6 +31,9 @@ import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Node.Contact (HyperdataContact, fake_HyperdataContact)
import Gargantext.Database.Types.Node (Node,Hyperdata, DocumentId, NodeId(..))
import Gargantext.Database.Utils (fromField')
import Gargantext.Database.Tools.Node (getNode)
import Gargantext.Database.Schema.Node (Node(..))
import Gargantext.Core.Types.Individu (Username, arbitraryUsername, User(..), UserId)
import Gargantext.Prelude
import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn)
import Test.QuickCheck (elements)
......@@ -126,5 +129,32 @@ $(deriveJSON (unPrefix "_hpr_") ''HyperdataPrivate)
$(deriveJSON (unPrefix "_hpu_") ''HyperdataPublic)
-----------------------------------------------------------------
getUserId :: HasNodeError err
=> User
-> Cmd err UserId
getUserId (UserDBId uid) = pure uid
getUserId (RootId rid) = do
n <- getNode rid
pure $ _node_userId n
getUserId (UserName u ) = do
muser <- getUser u
case muser of
Just user -> pure $ userLight_id user
Nothing -> nodeError NoUserFound
getNodeUser :: NodeId -> Cmd err (Node HyperdataUser)
getNodeUser nId = do
fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
where
name = maybe "User" identity maybeName
user = maybe fake_HyperdataUser identity maybeHyperdata
src/Gargantext/Database/Root.hs deleted 100644 → 0
View file @ b7355306
{-|
Module : Gargantext.Database.Root
Description : Main requests to get root of users
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Root where
import Control.Arrow (returnA)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Node.User (HyperdataUser)
import Gargantext.Database.Schema.Node (NodeRead)
import Gargantext.Database.Schema.Node (queryNodeTable)
import Gargantext.Database.Schema.User (queryUserTable, UserPoly(..))
import Gargantext.Database.Types.Node (Node, NodePoly(..), NodeType(NodeUser))
import Gargantext.Database.Utils (Cmd, runOpaQuery)
import Gargantext.Prelude
import Opaleye (restrict, (.==), Query)
import Opaleye.PGTypes (pgStrictText, pgInt4)
getRoot :: User -> Cmd err [Node HyperdataUser]
getRoot = runOpaQuery . selectRoot
selectRoot :: User -> Query NodeRead
selectRoot (UserName username) = proc () -> do
row <- queryNodeTable -< ()
users <- queryUserTable -< ()
restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
restrict -< user_username users .== (pgStrictText username)
restrict -< _node_userId row .== (user_id users)
returnA -< row
selectRoot (UserDBId uid) = proc () -> do
row <- queryNodeTable -< ()
restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
restrict -< _node_userId row .== (pgInt4 uid)
returnA -< row
src/Gargantext/Database/Tree.hs deleted 100644 → 0
View file @ b7355306
{-|
Module : Gargantext.Database.Tree
Description : Tree of Resource Nodes built from Database
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Let a Root Node, return the Tree of the Node as a directed acyclic graph
(Tree).
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Tree
( treeDB
, TreeError(..)
, HasTreeError(..)
, dbTree
, toNodeTree
, DbTreeNode
, isDescendantOf
, isIn
) where
import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
import Control.Monad.Error.Class (MonadError(throwError))
import Data.Map (Map, fromListWith, lookup)
import Data.Text (Text)
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.SqlQQ
import Gargantext.Prelude
import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
import Gargantext.Database.Config (fromNodeTypeId, nodeTypeId)
import Gargantext.Database.Types.Node (NodeId, NodeType, DocId, allNodeTypes)
import Gargantext.Database.Utils (Cmd, runPGSQuery)
------------------------------------------------------------------------
-- import Gargantext.Database.Utils (runCmdDev)
-- treeTest :: IO (Tree NodeTree)
-- treeTest = runCmdDev $ treeDB 347474
------------------------------------------------------------------------
data TreeError = NoRoot | EmptyRoot | TooManyRoots
deriving (Show)
class HasTreeError e where
_TreeError :: Prism' e TreeError
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 r nodeTypes = toTree =<< (toTreeParent <$> dbTree r nodeTypes)
type RootId = NodeId
type ParentId = NodeId
------------------------------------------------------------------------
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
Nothing -> treeError NoRoot
Just [] -> treeError EmptyRoot
Just _ -> treeError TooManyRoots
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 nId tId _ n) = NodeTree n nodeType nId
where
nodeType = fromNodeTypeId tId
------------------------------------------------------------------------
toTreeParent :: [DbTreeNode] -> Map (Maybe ParentId) [DbTreeNode]
toTreeParent = fromListWith (<>) . map (\n -> (dt_parentId n, [n]))
------------------------------------------------------------------------
data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
, dt_typeId :: Int
, dt_parentId :: Maybe NodeId
, dt_name :: Text
} deriving (Show)
-- | Main DB Tree function
-- TODO add typenames as parameters
dbTree :: RootId -> [NodeType] -> Cmd err [DbTreeNode]
dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
<$> runPGSQuery [sql|
WITH RECURSIVE
tree (id, typename, parent_id, name) AS
(
SELECT p.id, p.typename, p.parent_id, p.name
FROM nodes AS p
WHERE p.id = ?
UNION
SELECT c.id, c.typename, c.parent_id, c.name
FROM nodes AS c
INNER JOIN tree AS s ON c.parent_id = s.id
WHERE c.typename IN ?
)
SELECT * from tree;
|] (rootId, In typename)
where
typename = map nodeTypeId ns
ns = case nodeTypes of
[] -> allNodeTypes
-- [2, 20, 21, 22, 3, 5, 30, 31, 40, 7, 9, 90, 71]
_ -> nodeTypes
isDescendantOf :: NodeId -> RootId -> Cmd err Bool
isDescendantOf childId rootId = (== [Only True])
<$> runPGSQuery [sql|
BEGIN ;
SET TRANSACTION READ ONLY;
COMMIT;
WITH RECURSIVE
tree (id, parent_id) AS
(
SELECT c.id, c.parent_id
FROM nodes AS c
WHERE c.id = ?
UNION
SELECT p.id, p.parent_id
FROM nodes AS p
INNER JOIN tree AS t ON t.parent_id = p.id
)
SELECT COUNT(*) = 1 from tree AS t
WHERE t.id = ?;
|] (childId, rootId)
-- TODO should we check the category?
isIn :: NodeId -> DocId -> Cmd err Bool
isIn cId docId = ( == [Only True])
<$> runPGSQuery [sql| SELECT COUNT(*) = 1
FROM nodes_nodes nn
WHERE nn.node1_id = ?
AND nn.node2_id = ?;
|] (cId, docId)
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