Skip to content

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

Merge branch 'dev-public' into dev

parents f0d9255c c81552e7
Hide whitespace changes
Inline Side-by-side
Showing with 304 additions and 144 deletions
src/Gargantext/API.hs
View file @ fe4d4ab2
......@@ -76,6 +76,7 @@ import System.IO (FilePath)
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.Text.IO as T
import qualified Paths_gargantext as PG -- cabal magic build module
import qualified Gargantext.API.Public as Public
data Mode = Dev | Mock | Prod
......@@ -219,7 +220,7 @@ server :: forall env. EnvC env => env -> IO (Server API)
server env = do
-- orchestrator <- scrapyOrchestrator env
pure $ schemaUiServer swaggerDoc
:<|> hoistServerWithContext
:<|> hoistServerWithContext
(Proxy :: Proxy GargAPI)
(Proxy :: Proxy AuthContext)
transform
......@@ -240,6 +241,8 @@ serverGargAPI -- orchestrator
= auth
:<|> gargVersion
:<|> serverPrivateGargAPI
:<|> Public.api
-- :<|> orchestrator
where
......
src/Gargantext/API/Admin/Auth.hs
View file @ fe4d4ab2
......@@ -201,8 +201,7 @@ withAccessM uId (PathNodeNode cId docId) m = do
withAccess :: forall env err m api.
(GargServerC env err m, HasServer api '[]) =>
Proxy api -> Proxy m ->
UserId -> PathId ->
Proxy api -> Proxy m -> UserId -> PathId ->
ServerT api m -> ServerT api m
withAccess p _ uId id = hoistServer p f
where
......
src/Gargantext/API/Node.hs
View file @ fe4d4ab2
......@@ -46,7 +46,6 @@ import Gargantext.Core.Types (NodeTableResult)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Types.Main (Tree, NodeTree)
import Gargantext.Database.Action.Flow.Pairing (pairing)
import Gargantext.Database.Action.Share (unPublish)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude -- (Cmd, CmdM)
import Gargantext.Database.Query.Facet (FacetDoc, OrderBy(..))
......@@ -145,7 +144,7 @@ type NodeAPI a = Get '[JSON] (Node a)
:<|> "phylo" :> PhyloAPI
-- :<|> "add" :> NodeAddAPI
:<|> "move" :> MoveAPI
:<|> "unpublish" :> Put '[JSON] Int
:<|> "unpublish" :> Share.Unpublish
-- TODO-ACCESS: check userId CanRenameNode nodeId
-- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
......@@ -221,7 +220,7 @@ nodeAPI p uId id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode
:<|> moveNode (RootId $ NodeId uId) id'
-- :<|> nodeAddAPI id'
-- :<|> postUpload id'
:<|> unPublish (RootId $ NodeId uId) id'
:<|> Share.unPublish id'
------------------------------------------------------------------------
......
src/Gargantext/API/Node/Share.hs
View file @ fe4d4ab2
......@@ -20,8 +20,10 @@ import Data.Aeson
import Data.Swagger
import Data.Text (Text)
import GHC.Generics (Generic)
import Gargantext.API.Prelude
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.Share (shareNodeWith)
import Gargantext.Database.Action.Share (ShareNodeWith(..))
import Gargantext.Database.Action.Share as DB (shareNodeWith, unPublish)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
......@@ -31,37 +33,40 @@ import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
------------------------------------------------------------------------
data ShareNode = ShareTeam { username :: Text }
| SharePublic { rights :: Text}
data ShareNodeParams = ShareTeamParams { username :: Text }
| SharePublicParams { node_id :: NodeId}
deriving (Generic)
------------------------------------------------------------------------
-- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
instance FromJSON ShareNode where
instance FromJSON ShareNodeParams where
parseJSON = genericParseJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
instance ToJSON ShareNode where
instance ToJSON ShareNodeParams where
toJSON = genericToJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
instance ToSchema ShareNode
instance Arbitrary ShareNode where
arbitrary = elements [ ShareTeam "user1"
, SharePublic "public"
instance ToSchema ShareNodeParams
instance Arbitrary ShareNodeParams where
arbitrary = elements [ ShareTeamParams "user1"
, SharePublicParams (NodeId 1)
]
------------------------------------------------------------------------
-- TODO permission
api :: HasNodeError err
=> NodeId
-> ShareNode
-> ShareNodeParams
-> Cmd err Int
api nId (ShareTeam user) =
fromIntegral <$> shareNodeWith nId NodeFolderShared (UserName user)
api nId (SharePublic _rights) =
fromIntegral <$> shareNodeWith nId NodeFolderPublic UserPublic
api nId (ShareTeamParams user) =
fromIntegral <$> DB.shareNodeWith (ShareNodeWith_User NodeFolderShared (UserName user)) nId
api nId2 (SharePublicParams nId1) =
fromIntegral <$> DB.shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId1) nId2
------------------------------------------------------------------------
type API = Summary " Share Node with username"
:> ReqBody '[JSON] ShareNode
:> ReqBody '[JSON] ShareNodeParams
:> Post '[JSON] Int
------------------------------------------------------------------------
type Unpublish = Summary " Unpublish Node"
:> Capture "node_id" NodeId
:> Put '[JSON] Int
unPublish :: NodeId -> GargServer Unpublish
unPublish n = DB.unPublish n
src/Gargantext/API/Public.hs 0 → 100644
View file @ fe4d4ab2
{-|
Module : Gargantext.API.Public
Description :
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Gargantext.API.Public
where
import Control.Lens ((^?), (^.), _Just)
import Data.Maybe (maybe, catMaybes)
import Data.Tuple (snd)
import Data.Text (Text)
import Data.List (replicate, null)
import Data.Aeson
import Data.Swagger
import GHC.Generics (Generic)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Prelude
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Query.Table.NodeNode (selectPublicNodes)
import Gargantext.Core.Utils.DateUtils (utc2year)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Schema.Node -- (NodePoly(..))
import Gargantext.Prelude
import Servant
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import qualified Data.Map as Map
------------------------------------------------------------------------
type API = Summary " Public API"
:> Get '[JSON] [PublicData]
api :: HasNodeError err
=> Cmd err [PublicData]
api = catMaybes <$> map toPublicData <$> filterPublicDatas <$> selectPublic
selectPublic :: HasNodeError err
=> Cmd err [( Node HyperdataFolder, Maybe Int)]
selectPublic = selectPublicNodes
-- | For tests only
-- pure $ replicate 6 defaultPublicData
filterPublicDatas :: [( Node HyperdataFolder, Maybe Int)] -> [(Node HyperdataFolder, [NodeId])]
filterPublicDatas datas = map (\(n,mi) -> let mi' = NodeId <$> mi in
( _node_id n, (n, maybe [] (:[]) mi' ))
) datas
& Map.fromListWith (\(n1,i1) (_n2,i2) -> (n1, i1 <> i2))
& Map.filter (not . null . snd)
& Map.elems
toPublicData :: (Node HyperdataFolder, [NodeId]) -> Maybe PublicData
toPublicData (n , _mn) = PublicData <$> (hd ^? (_Just . hf_data . cf_title))
<*> (hd ^? (_Just . hf_data . cf_desc))
<*> Just "images/Gargantextuel-212x300.jpg"
<*> Just "https://.."
<*> Just (cs $ show $ utc2year (n^.node_date))
<*> (hd ^? (_Just . hf_data . cf_query))
<*> (hd ^? (_Just . hf_data . cf_authors))
where
hd = head
$ filter (\(HyperdataField cd _ _) -> cd == JSON)
$ n^. (node_hyperdata . hc_fields)
data PublicData = PublicData
{ title :: Text
, abstract :: Text
, img :: Text
, url :: Text
, date :: Text
, database :: Text
, author :: Text
} | NoData { nodata:: Text}
deriving (Generic)
instance FromJSON PublicData where
parseJSON = genericParseJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
instance ToJSON PublicData where
toJSON = genericToJSON (defaultOptions { sumEncoding = ObjectWithSingleField })
instance ToSchema PublicData
instance Arbitrary PublicData where
arbitrary = elements
$ replicate 6 defaultPublicData
defaultPublicData :: PublicData
defaultPublicData =
PublicData "Title"
(foldl (<>) "" $ replicate 100 "abstract ")
"images/Gargantextuel-212x300.jpg"
"https://.."
"YY/MM/DD"
"database"
"Author"
src/Gargantext/API/Routes.hs
View file @ fe4d4ab2
......@@ -24,34 +24,34 @@ Portability : POSIX
module Gargantext.API.Routes
where
---------------------------------------------------------------------
import Control.Concurrent (threadDelay)
import Data.Text (Text)
import Data.Validity
import Servant
import Servant.Auth as SA
import Servant.Auth.Swagger ()
import Servant.Job.Async
import Servant.Swagger.UI
import Gargantext.API.Admin.Auth (AuthRequest, AuthResponse, AuthenticatedUser(..), withAccess, PathId(..))
import Gargantext.API.Admin.FrontEnd (FrontEndAPI)
import Gargantext.API.Prelude
import Gargantext.API.Count (CountAPI, count, Query)
import Gargantext.API.Ngrams (TableNgramsApi, apiNgramsTableDoc)
import Gargantext.API.Node
import Gargantext.API.Prelude
import Gargantext.API.Search (SearchPairsAPI, searchPairs)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Query.Table.Node.Contact (HyperdataContact)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Admin.Types.Node (NodeId, CorpusId, AnnuaireId)
import Gargantext.Database.Query.Table.Node.Contact (HyperdataContact)
import Gargantext.Prelude
import Gargantext.Viz.Graph.API
import Servant
import Servant.Auth as SA
import Servant.Auth.Swagger ()
import Servant.Job.Async
import Servant.Swagger.UI
import qualified Gargantext.API.Ngrams.List as List
import qualified Gargantext.API.Node.Corpus.Annuaire as Annuaire
import qualified Gargantext.API.Node.Corpus.Export as Export
import qualified Gargantext.API.Node.Corpus.New as New
import qualified Gargantext.API.Ngrams.List as List
import qualified Gargantext.API.Public as Public
type GargAPI = "api" :> Summary "API " :> GargAPIVersion
......@@ -75,6 +75,7 @@ type GargAPI' =
-- TODO-ACCESS here we want to request a particular header for
-- auth and capabilities.
:<|> GargPrivateAPI
:<|> "public" :> Public.API
type GargPrivateAPI = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser
......
src/Gargantext/Database/Action/Node.hs
View file @ fe4d4ab2
......@@ -101,7 +101,10 @@ mkNodeWithParent NodeFrameWrite i u n =
mkNodeWithParent NodeFrameCalc i u n =
mkNodeWithParent_ConfigureHyperdata NodeFrameCalc i u n
mkNodeWithParent _ _ _ _ = nodeError NotImplYet
mkNodeWithParent n (Just i) uId name =
insertNodesWithParentR (Just i) [node NodeDashboard name (hasDefaultData n) Nothing uId]
-- mkNodeWithParent _ _ _ _ = nodeError NotImplYet
-- | Sugar to create a node, get his NodeId and update his Hyperdata after
......
src/Gargantext/Database/Action/Share.hs
View file @ fe4d4ab2
......@@ -9,72 +9,87 @@ Portability : POSIX
-}
module Gargantext.Database.Action.Share
where
import Control.Lens (view)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.Flow.Utils (getUserId)
import Gargantext.Database.Admin.Config (hasNodeType)
import Gargantext.Database.Admin.Config (hasNodeType, isInNodeTypes)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny(..))
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Admin.Types.Node -- (NodeType(..))
import Gargantext.Database.Prelude (Cmd)
import Gargantext.Database.Query.Table.Node (getNode, getNodesWith)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError, msg)
import Gargantext.Database.Query.Table.NodeNode (insertNodeNode, deleteNodeNode)
import Gargantext.Database.Query.Tree.Root (getRootId)
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.NodeNode (NodeNodePoly(..))
import Gargantext.Prelude
-- | TODO move in Config of Gargantext
publicNodeTypes :: [NodeType]
publicNodeTypes = [NodeDashboard, NodeGraph, NodePhylo]
------------------------------------------------------------------------
data ShareNodeWith = ShareNodeWith_User { snwu_nodetype :: NodeType
, snwu_user :: User }
| ShareNodeWith_Node { snwn_nodetype :: NodeType
, snwn_node_id :: NodeId
}
------------------------------------------------------------------------
shareNodeWith :: HasNodeError err
=> NodeId
-> NodeType
-> User
=> ShareNodeWith
-> NodeId
-> Cmd err Int64
shareNodeWith n nt u = do
shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
nodeToCheck <- getNode n
case nt of
NodeFolderShared -> do
userIdCheck <- getUserId u
if not (hasNodeType nodeToCheck NodeTeam)
then panic "Can share node Team only"
else
if (view node_userId nodeToCheck == userIdCheck)
then panic "Can share to others only"
else do
folderSharedId <- getFolderId u NodeFolderShared
insertNodeNode [NodeNode folderSharedId n Nothing Nothing]
NodeFolderPublic -> if not (hasNodeType nodeToCheck NodeGraph)
then panic "Can share node graph only"
else do
folderId <- getFolderId (UserDBId $ view node_userId nodeToCheck) NodeFolderPublic
insertNodeNode [NodeNode folderId n Nothing Nothing]
_ -> panic "shareNodeWith not implemented with this NodeType"
userIdCheck <- getUserId u
if not (hasNodeType nodeToCheck NodeTeam)
then msg "Can share node Team only"
else
if (view node_userId nodeToCheck == userIdCheck)
then msg "Can share to others only"
else do
folderSharedId <- getFolderId u NodeFolderShared
insertNodeNode [NodeNode folderSharedId n Nothing Nothing]
shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
nodeToCheck <- getNode n
if not (isInNodeTypes nodeToCheck publicNodeTypes)
then msg $ "Can share this nodesTypes only: " <> (cs $ show publicNodeTypes)
else do
folderToCheck <- getNode nId
if hasNodeType folderToCheck NodeFolderPublic
then insertNodeNode [NodeNode nId n Nothing Nothing]
else msg "Can share NodeWith NodeFolderPublic only"
shareNodeWith _ _ = msg "shareNodeWith not implemented for this NodeType"
------------------------------------------------------------------------
getFolderId :: User -> NodeType -> Cmd err NodeId
getFolderId :: HasNodeError err => User -> NodeType -> Cmd err NodeId
getFolderId u nt = do
rootId <- getRootId u
s <- getNodesWith rootId HyperdataAny (Just nt) Nothing Nothing
case head s of
Nothing -> panic "No folder shared found"
Nothing -> msg "No folder shared found"
Just f -> pure (_node_id f)
------------------------------------------------------------------------
type TeamId = NodeId
delFolderTeam :: User -> TeamId -> Cmd err Int
delFolderTeam :: HasNodeError err => User -> TeamId -> Cmd err Int
delFolderTeam u nId = do
folderSharedId <- getFolderId u NodeFolderShared
deleteNodeNode folderSharedId nId
unPublish :: User -> NodeId -> Cmd err Int
unPublish u nId = do
folderId <- getFolderId u NodeFolderPublic
deleteNodeNode folderId nId
unPublish :: HasNodeError err
=> ParentId -> NodeId
-> Cmd err Int
unPublish p n = deleteNodeNode p n
src/Gargantext/Database/Admin/Config.hs
View file @ fe4d4ab2
......@@ -87,6 +87,8 @@ nodeTypeId n =
hasNodeType :: forall a. Node a -> NodeType -> Bool
hasNodeType n nt = (view node_typename n) == (nodeTypeId nt)
isInNodeTypes :: forall a. Node a -> [NodeType] -> Bool
isInNodeTypes n ts = elem (view node_typename n) (map nodeTypeId ts)
-- | Nodes are typed in the database according to a specific ID
--
......
src/Gargantext/Database/Admin/Types/Hyperdata.hs
View file @ fe4d4ab2
......@@ -35,7 +35,7 @@ import Gargantext.Viz.Types (Histo(..))
data CodeType = JSON | Markdown | Haskell
deriving (Generic)
deriving (Generic, Eq)
instance ToJSON CodeType
instance FromJSON CodeType
instance ToSchema CodeType
......@@ -57,6 +57,12 @@ data CorpusField = MarkdownField { _cf_text :: !Text }
| HaskellField { _cf_haskell :: !Text }
deriving (Generic)
isField :: CodeType -> CorpusField -> Bool
isField Markdown (MarkdownField _) = True
isField JSON (JsonField _ _ _ _) = True
isField Haskell (HaskellField _) = True
isField _ _ = False
$(deriveJSON (unPrefix "_cf_") ''CorpusField)
$(makeLenses ''CorpusField)
......@@ -194,6 +200,7 @@ $(makeLenses ''HyperdataCorpus)
instance Hyperdata HyperdataCorpus
type HyperdataFolder = HyperdataCorpus
------------------------------------------------------------------------
data HyperdataFrame =
HyperdataFrame { base :: !Text
......@@ -296,38 +303,25 @@ $(deriveJSON (unPrefix "hyperdataResource_") ''HyperdataResource)
instance Hyperdata HyperdataResource
------------------------------------------------------------------------
data HyperdataDashboard = HyperdataDashboard { hyperdataDashboard_preferences :: !(Maybe Text)
, hyperdataDashboard_charts :: ![Chart]
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataDashboard_") ''HyperdataDashboard)
instance Hyperdata HyperdataDashboard
------------------------------------------------------------------------
-- TODO add the Graph Structure here
data HyperdataPhylo = HyperdataPhylo { hyperdataPhylo_preferences :: !(Maybe Text)
, hyperdataPhylo_data :: !(Maybe Phylo)
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataPhylo_") ''HyperdataPhylo)
instance Hyperdata HyperdataPhylo
------------------------------------------------------------------------
-- | TODO FEATURE: Notebook saved in the node
data HyperdataNotebook = HyperdataNotebook { hyperdataNotebook_preferences :: !(Maybe Text)
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataNotebook_") ''HyperdataNotebook)
instance Hyperdata HyperdataNotebook
-- | TODO CLEAN
-- | TODO FEATURE: Notebook saved in the node
data HyperData = HyperdataTexts { hd_preferences :: !(Maybe Text)}
| HyperdataList' { hd_preferences :: !(Maybe Text)}
| HyperdataDashboard { hd_preferences :: !(Maybe Text)
, hd_charts :: ![Chart]
}
| HyperdataNotebook { hd_preferences :: !(Maybe Text)}
| HyperdataPhylo { hd_preferences :: !(Maybe Text)
, hd_data :: !(Maybe Phylo)
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "hd_") ''HyperData)
instance Hyperdata HyperData
------------------------------------------------------------------------
......@@ -395,10 +389,6 @@ instance FromField HyperdataListModel
where
fromField = fromField'
instance FromField HyperdataPhylo
where
fromField = fromField'
instance FromField HyperdataAnnuaire
where
fromField = fromField'
......@@ -437,10 +427,6 @@ instance QueryRunnerColumnDefault PGJsonb HyperdataListModel
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault PGJsonb HyperdataPhylo
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
src/Gargantext/Database/Admin/Types/Node.hs
View file @ fe4d4ab2
......@@ -233,10 +233,6 @@ instance Arbitrary Resource where
instance ToSchema Resource where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "resource_")
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | Then a Node can be either a Folder or a Corpus or a Document
data NodeType = NodeUser
......@@ -280,6 +276,8 @@ instance ToSchema NodeType
instance Arbitrary NodeType where
arbitrary = elements allNodeTypes
------------------------------------------------------------------------
-- Instances
------------------------------------------------------------------------
......@@ -311,5 +309,3 @@ instance QueryRunnerColumnDefault (Nullable PGInt4) NodeId
queryRunnerColumnDefault = fieldQueryRunnerColumn
src/Gargantext/Database/Query/Table/Node.hs
View file @ fe4d4ab2
......@@ -228,17 +228,20 @@ class HasDefault a where
instance HasDefault NodeType where
hasDefaultData nt = case nt of
NodeTexts -> HyperdataTexts (Just "Preferences")
NodeList -> HyperdataList' (Just "Preferences")
NodeListCooc -> HyperdataList' (Just "Preferences")
_ -> undefined
NodeTexts -> HyperdataTexts (Just "Preferences")
NodeList -> HyperdataList' (Just "Preferences")
NodeListCooc -> HyperdataList' (Just "Preferences")
-- NodeFolder -> defaultFolder
NodeDashboard -> arbitraryDashboard
_ -> panic "HasDefaultData undefined"
--NodeAnnuaire -> HyperdataAnnuaire (Just "Title") (Just "Description")
hasDefaultName nt = case nt of
NodeTexts -> "Texts"
NodeList -> "Lists"
NodeListCooc -> "Cooc"
_ -> undefined
NodePhylo -> "Phylo"
_ -> panic "HasDefaultName undefined"
------------------------------------------------------------------------
nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
......@@ -277,17 +280,7 @@ 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 :: HyperData
arbitraryDashboard = HyperdataDashboard (Just "Preferences") []
------------------------------------------------------------------------
......@@ -446,16 +439,12 @@ 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 :: Maybe Name -> Maybe HyperData -> 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]
getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
......
src/Gargantext/Database/Query/Table/Node/Error.hs
View file @ fe4d4ab2
......@@ -19,6 +19,7 @@ Portability : POSIX
module Gargantext.Database.Query.Table.Node.Error where
import Data.Text (Text)
import Gargantext.Database.Admin.Types.Node (NodeId)
import Control.Lens (Prism', (#), (^?))
import Control.Monad.Error.Class (MonadError(..))
......@@ -39,6 +40,7 @@ data NodeError = NoListFound
| ManyNodeUsers
| DoesNotExist NodeId
| NeedsConfiguration
| NodeError Text
instance Show NodeError
where
......@@ -56,10 +58,16 @@ instance Show NodeError
show ManyNodeUsers = "Many userNode/user"
show (DoesNotExist n) = "Node does not exist" <> show n
show NeedsConfiguration = "Needs configuration"
show (NodeError e) = "NodeError: " <> cs e
class HasNodeError e where
_NodeError :: Prism' e NodeError
msg :: ( MonadError e m
, HasNodeError e)
=> Text -> m a
msg x = nodeError (NodeError x)
nodeError :: ( MonadError e m
, HasNodeError e)
=> NodeError -> m a
......
src/Gargantext/Database/Query/Table/NodeNode.hs
View file @ fe4d4ab2
......@@ -28,6 +28,7 @@ module Gargantext.Database.Query.Table.NodeNode
, getNodeNode
, insertNodeNode
, deleteNodeNode
, selectPublicNodes
)
where
......@@ -153,3 +154,21 @@ joinInCorpus = leftJoin queryNodeTable queryNodeNodeTable cond
cond :: (NodeRead, NodeNodeRead) -> Column PGBool
cond (n, nn) = nn^.nn_node2_id .== (view node_id n)
joinOn1 :: O.Query (NodeRead, NodeNodeReadNull)
joinOn1 = leftJoin queryNodeTable queryNodeNodeTable cond
where
cond :: (NodeRead, NodeNodeRead) -> Column PGBool
cond (n, nn) = nn^.nn_node1_id .== n^.node_id
------------------------------------------------------------------------
selectPublicNodes :: (Hyperdata a, QueryRunnerColumnDefault PGJsonb a)
=> Cmd err [(Node a, Maybe Int)]
selectPublicNodes = runOpaQuery (queryWithType NodeFolderPublic)
queryWithType :: NodeType -> O.Query (NodeRead, Column (Nullable PGInt4))
queryWithType nt = proc () -> do
(n, nn) <- joinOn1 -< ()
restrict -< n^.node_typename .== (pgInt4 $ nodeTypeId nt)
returnA -< (n, nn^.nn_node2_id)
src/Gargantext/Database/Query/Tree.hs
View file @ fe4d4ab2
......@@ -40,7 +40,7 @@ import Data.Text (Text)
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.SqlQQ
import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
import Gargantext.Database.Admin.Config (fromNodeTypeId, nodeTypeId)
import Gargantext.Database.Admin.Config (fromNodeTypeId, nodeTypeId, fromNodeTypeId)
import Gargantext.Database.Admin.Types.Node (NodeId, NodeType, DocId, allNodeTypes)
import Gargantext.Database.Admin.Types.Node -- (pgNodeId, NodeType(..))
import Gargantext.Database.Prelude (Cmd, runPGSQuery)
......@@ -89,28 +89,48 @@ tree_advanced :: HasTreeError err
-> Cmd err (Tree NodeTree)
tree_advanced r nodeTypes = do
mainRoot <- dbTree r nodeTypes
sharedRoots <- findShared r NodeFolderShared nodeTypes
publicRoots <- findShared r NodeFolderPublic nodeTypes
sharedRoots <- findShared r NodeFolderShared nodeTypes sharedTreeUpdate
publicRoots <- findShared r NodeFolderPublic nodeTypes publicTreeUpdate
toTree $ toTreeParent (mainRoot <> sharedRoots <> publicRoots)
------------------------------------------------------------------------
-- | Collaborative Nodes in the Tree
findShared :: RootId -> NodeType -> [NodeType] -> Cmd err [DbTreeNode]
findShared r nt nts = do
folderSharedId <- maybe (panic "no folder found") identity
<$> head
<$> findNodesId r [nt]
folders <- getNodeNode folderSharedId
nodesSharedId <- mapM (\child -> sharedTree folderSharedId child nts)
findShared :: HasTreeError err
=> RootId -> NodeType -> [NodeType] -> UpdateTree err
-> Cmd err [DbTreeNode]
findShared r nt nts fun = do
foldersSharedId <- findNodesId r [nt]
trees <- mapM (updateTree nts fun) foldersSharedId
pure $ concat trees
updateTree :: HasTreeError err
=> [NodeType] -> UpdateTree err -> RootId
-> Cmd err [DbTreeNode]
updateTree nts fun r = do
folders <- getNodeNode r
nodesSharedId <- mapM (fun r nts)
$ map _nn_node2_id folders
pure $ concat nodesSharedId
sharedTree :: ParentId -> NodeId -> [NodeType] -> Cmd err [DbTreeNode]
sharedTree p n nt = dbTree n nt
<&> map (\n' -> if _dt_nodeId n' == n
type UpdateTree err = ParentId -> [NodeType] -> NodeId -> Cmd err [DbTreeNode]
sharedTreeUpdate :: HasTreeError err => UpdateTree err
sharedTreeUpdate p nt n = dbTree n nt
<&> map (\n' -> if _dt_nodeId n' == n
then set dt_parentId (Just p) n'
else n')
publicTreeUpdate :: HasTreeError err => UpdateTree err
publicTreeUpdate p nt n = dbTree n nt
<&> map (\n' -> if _dt_nodeId n' == n
-- && (fromNodeTypeId $ _dt_typeId n') /= NodeFolderPublic
then set dt_parentId (Just p) n'
else n')
-- | findNodesId returns all nodes matching nodeType but the root (Nodeuser)
findNodesId :: RootId -> [NodeType] -> Cmd err [NodeId]
findNodesId r nt = tail
......
src/Gargantext/Viz/Phylo/API.hs
View file @ fe4d4ab2
......@@ -32,7 +32,7 @@ import Web.HttpApiData (parseUrlPiece, readTextData)
import Gargantext.API.Prelude
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Node -- (PhyloId, ListId, CorpusId, UserId, NodeId(..))
import Gargantext.Database.Query.Table.Node (insertNodes, nodePhyloW, getNodeWith)
import Gargantext.Database.Query.Table.Node (insertNodes, node, getNodeWith)
import Gargantext.Database.Schema.Node (_node_hyperdata)
import Gargantext.Prelude
import Gargantext.Viz.Phylo
......@@ -95,15 +95,16 @@ type GetPhylo = QueryParam "listId" ListId
-- Add real text processing
-- Fix Filter parameters
getPhylo :: PhyloId -> GargServer GetPhylo
--getPhylo phId _lId l msb _f _b _l' _ms _x _y _z _ts _s _o _e _d _b' = do
getPhylo phId _lId l msb = do
phNode <- getNodeWith phId (Proxy :: Proxy HyperdataPhylo)
phNode <- getNodeWith phId (Proxy :: Proxy HyperData)
let
level = maybe 2 identity l
branc = maybe 2 identity msb
maybePhylo = hyperdataPhylo_data $ _node_hyperdata phNode
maybePhylo = hd_data $ _node_hyperdata phNode
p <- liftBase $ viewPhylo2Svg $ viewPhylo level branc $ maybe phyloFromQuery identity maybePhylo
p <- liftBase $ viewPhylo2Svg
$ viewPhylo level branc
$ maybe phyloFromQuery identity maybePhylo
pure (SVG p)
------------------------------------------------------------------------
type PostPhylo = QueryParam "listId" ListId
......@@ -119,7 +120,7 @@ postPhylo n userId _lId = do
-- _sft = Just (Software "Gargantext" "4")
-- _prm = initPhyloParam vrs sft (Just q)
phy <- flowPhylo n
pId <- insertNodes [nodePhyloW (Just "Phylo") (Just $ HyperdataPhylo Nothing (Just phy)) n userId]
pId <- insertNodes [node NodePhylo "Phylo" (HyperdataPhylo Nothing (Just phy)) (Just n) userId]
pure $ NodeId (fromIntegral pId)
------------------------------------------------------------------------
......
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