Commit e79541d7 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

Almost there?

parent 5f157876
......@@ -33,7 +33,7 @@ import Gargantext.API.Prelude (GargM)
import Gargantext.Core.Types.Search (HyperdataRow(..), toHyperdataRow)
import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument )
import Gargantext.Database.Admin.Types.Node (ContextTitle, NodeId(..), NodeTypeId, UserId, unNodeId, ContextId (..))
import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.NodeContext (getNodeContext, getContextsForNgramsTerms, ContextForNgramsTerms(..), {- getContextNgrams, -} getContextNgramsMatchingFTS)
import Gargantext.Database.Query.Table.NodeContext qualified as DNC
import Gargantext.Database.Schema.NodeContext (NodeContext, NodeContextPoly(..))
......@@ -147,7 +147,7 @@ dbNodeContext context_id node_id = do
-- user <- getUsersWithId user_id
-- hyperdata <- getUserHyperdata user_id
-- lift (map toUser <$> zip user hyperdata)
c <- lift $ getNodeContext (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id)
c <- lift $ runDBQuery $ getNodeContext (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id)
pure $ toNodeContextGQL <$> [c]
-- | Returns list of `ContextGQL` for given ngrams in given corpus id.
......@@ -155,7 +155,7 @@ dbContextForNgrams
:: (IsDBEnvExtra env)
=> Int -> [Text] -> Text -> GqlM e env [ContextGQL]
dbContextForNgrams node_id ngrams_terms and_logic = do
contextsForNgramsTerms <- lift $ getContextsForNgramsTerms (UnsafeMkNodeId node_id) ngrams_terms ( readMaybe $ unpack $ Text.toTitle and_logic )
contextsForNgramsTerms <- lift $ runDBQuery $ getContextsForNgramsTerms (UnsafeMkNodeId node_id) ngrams_terms ( readMaybe $ unpack $ Text.toTitle and_logic )
--lift $ printDebug "[dbContextForNgrams] contextsForNgramsTerms" contextsForNgramsTerms
pure $ toContextGQL <$> contextsForNgramsTerms
......@@ -164,7 +164,7 @@ dbContextNgrams
:: (IsDBEnvExtra env)
=> Int -> Int -> GqlM e env [Text]
dbContextNgrams context_id list_id = do
lift $ getContextNgramsMatchingFTS (UnsafeMkContextId context_id) (UnsafeMkNodeId list_id)
lift $ runDBQuery $ getContextNgramsMatchingFTS (UnsafeMkContextId context_id) (UnsafeMkNodeId list_id)
-- Conversion functions
......@@ -228,5 +228,5 @@ updateNodeContextCategory :: (IsDBEnvExtra env)
-> GqlM' e env [Int]
updateNodeContextCategory autUser mgr NodeContextCategoryMArgs { context_id, node_id, category } =
withPolicy autUser mgr (nodeWriteChecks $ UnsafeMkNodeId node_id) $ do
void $ lift $ DNC.updateNodeContextCategory (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id) category
void $ lift $ runDBTx $ DNC.updateNodeContextCategory (UnsafeMkContextId context_id) (UnsafeMkNodeId node_id) category
pure [1]
......@@ -24,7 +24,7 @@ import Gargantext.API.GraphQL.Types ( GqlM )
import Gargantext.Core ( HasDBid(lookupDBid) )
import Gargantext.Database.Admin.Types.Node (NodeType)
import Gargantext.Database.Admin.Types.Node qualified as NN
import Gargantext.Database.Prelude (IsDBEnvExtra) -- , JSONB)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node (getClosestChildrenByType, getClosestParentIdByType, getNode)
import Gargantext.Database.Schema.Node qualified as N
import Gargantext.Prelude
......@@ -74,14 +74,14 @@ dbNodes
:: (IsDBEnvExtra env)
=> Int -> GqlM e env [Node]
dbNodes node_id = do
node <- lift $ getNode $ NN.UnsafeMkNodeId node_id
node <- lift $ runDBQuery $ getNode $ NN.UnsafeMkNodeId node_id
pure [toNode node]
dbNodesCorpus
:: (IsDBEnvExtra env)
=> Int -> GqlM e env [Corpus]
dbNodesCorpus corpus_id = do
corpus <- lift $ getNode $ NN.UnsafeMkNodeId corpus_id
corpus <- lift $ runDBQuery $ getNode $ NN.UnsafeMkNodeId corpus_id
pure [toCorpus corpus]
data NodeParentArgs
......@@ -116,19 +116,21 @@ dbParentNodes node_id parentType = do
-- lift $ printDebug "[dbParentNodes] error reading parent type" (T.pack err)
-- pure []
-- Right parentType -> do
mNodeId <- lift $ getClosestParentIdByType (NN.UnsafeMkNodeId node_id) parentType -- (fromNodeTypeId parent_type_id)
lift $ runDBQuery $ do
mNodeId <- getClosestParentIdByType (NN.UnsafeMkNodeId node_id) parentType -- (fromNodeTypeId parent_type_id)
case mNodeId of
Nothing -> pure []
Just id -> do
node <- lift $ getNode id
node <- getNode id
pure [toNode node]
dbChildNodes :: (IsDBEnvExtra env)
=> Int -> NodeType -> GqlM e env [Node]
dbChildNodes node_id childType = do
childIds <- lift $ getClosestChildrenByType (NN.UnsafeMkNodeId node_id) childType -- (fromNodeTypeId parent_type_id)
children <- lift $ mapM getNode childIds
pure $ toNode <$> children
lift $ runDBQuery $ do
childIds <- getClosestChildrenByType (NN.UnsafeMkNodeId node_id) childType -- (fromNodeTypeId parent_type_id)
children <- mapM getNode childIds
pure $ toNode <$> children
toNode :: NN.Node json -> Node
toNode N.Node { .. } = Node { id = nid
......
......@@ -25,7 +25,7 @@ import Gargantext.Core.Config (HasJWTSettings)
import Gargantext.Core.Types (NodeId(..), unNodeId)
import Gargantext.Core.Types.Individu qualified as Individu
import Gargantext.Database.Action.Share (membersOf, deleteMemberShip)
import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Query.Table.User (getUsersWithNodeHyperdata)
import Gargantext.Database.Schema.Node (NodePoly(Node, _node_id), _node_user_id)
......@@ -60,13 +60,14 @@ dbTeam :: (IsDBEnvExtra env) =>
Int -> GqlM e env Team
dbTeam nodeId = do
let nId = UnsafeMkNodeId nodeId
res <- lift $ membersOf nId
teamNode <- lift $ getNode nId
userNodes <- lift $ getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode
let username = getUsername userNodes
pure $ Team { team_owner_username = username
, team_members = map toTeamMember res
}
lift $ runDBQuery $ do
res <- membersOf nId
teamNode <- getNode nId
userNodes <- getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode
let username = getUsername userNodes
pure $ Team { team_owner_username = username
, team_members = map toTeamMember res
}
where
toTeamMember :: (Text, NodeId) -> TeamMember
toTeamMember (username, fId)= TeamMember {
......@@ -81,18 +82,19 @@ dbTeam nodeId = do
deleteTeamMembership :: (IsDBEnvExtra env, HasJWTSettings env) =>
TeamDeleteMArgs -> GqlM' e env [Int]
deleteTeamMembership TeamDeleteMArgs { token, shared_folder_id, team_node_id } = do
teamNode <- lift $ getNode $ UnsafeMkNodeId team_node_id
userNodes <- lift (getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode)
userNodes <- lift $ runDBTx $ do
teamNode <- getNode $ UnsafeMkNodeId team_node_id
getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode
case userNodes of
[] -> panicTrace $ "[deleteTeamMembership] User with id " <> T.pack (show $ uId teamNode) <> " doesn't exist."
[] -> panicTrace $ "[deleteTeamMembership] User with id " <> T.pack (show $ team_node_id) <> " doesn't exist."
(( _, node_u):_) -> do
testAuthUser <- lift $ authUser (nId node_u) token
lift $ case testAuthUser of
case testAuthUser of
-- Invalid -> panicTrace "[deleteTeamMembership] failed to validate user"
Invalid -> do
throwError $ InternalAuthenticationError $ UserNotAuthorized (uId node_u) "This user is not team owner"
lift $ throwError $ InternalAuthenticationError $ UserNotAuthorized (uId node_u) "This user is not team owner"
Valid -> do
deleteMemberShip [(UnsafeMkNodeId shared_folder_id, UnsafeMkNodeId team_node_id)]
lift $ runDBTx $ deleteMemberShip [(UnsafeMkNodeId shared_folder_id, UnsafeMkNodeId team_node_id)]
where
uId Node { _node_user_id } = _node_user_id
nId Node { _node_id } = _node_id
......@@ -25,7 +25,7 @@ import Gargantext.Core.Types.Main ( Tree(..), _tn_node, _tn_children, NodeTree(.
import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Admin.Types.Node (allNodeTypes, NodeId(..), NodeType)
import Gargantext.Database.Admin.Types.Node qualified as NN
import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Query.Tree qualified as T
import Gargantext.Database.Schema.Node (NodePoly(_node_parent_id))
......@@ -77,10 +77,11 @@ dbTree :: (IsDBEnvExtra env) =>
NN.UserId -> Int -> GqlM e env (TreeFirstLevel (GqlM e env))
dbTree loggedInUserId root_id = do
let rId = UnsafeMkNodeId root_id
t <- lift $ T.tree loggedInUserId T.TreeFirstLevel rId allNodeTypes
n <- lift $ getNode $ UnsafeMkNodeId root_id
let pId = toParentId n
pure $ toTree rId pId t
lift $ runDBQuery $ do
t <- T.tree loggedInUserId T.TreeFirstLevel rId allNodeTypes
n <- getNode $ UnsafeMkNodeId root_id
let pId = toParentId n
pure $ toTree rId pId t
where
toParentId N.Node { _node_parent_id } = _node_parent_id
......@@ -100,7 +101,7 @@ childrenToTreeNodes (TreeN {_tn_node}, rId) = toTreeNode (Just rId) _tn_node
resolveParent :: (IsDBEnvExtra env) => Maybe NodeId -> GqlM e env (Maybe TreeNode)
resolveParent (Just pId) = do
node <- lift $ getNode pId
node <- lift $ runDBQuery $ getNode pId
pure $ nodeToTreeNode node
resolveParent Nothing = pure Nothing
......@@ -133,6 +134,6 @@ convertDbTreeToTreeNode T.DbTreeNode { _dt_name, _dt_nodeId, _dt_typeId, _dt_par
dbRecursiveParents :: (IsDBEnvExtra env) => Int -> GqlM e env BreadcrumbInfo
dbRecursiveParents nodeId = do
let nId = UnsafeMkNodeId nodeId
dbParents <- lift $ T.recursiveParents nId allNodeTypes
dbParents <- lift $ runDBQuery $ T.recursiveParents nId allNodeTypes
let treeNodes = map convertDbTreeToTreeNode dbParents
pure $ BreadcrumbInfo { parents = treeNodes }
......@@ -22,7 +22,7 @@ import Gargantext.API.GraphQL.Types (GqlM, GqlM')
import Gargantext.Core.Types (NodeId(..), UserId)
import Gargantext.Core.Types.Individu qualified as Individu
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..))
import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.User qualified as DBUser
import Gargantext.Database.Schema.User (UserLight(..))
import Gargantext.Prelude
......@@ -72,7 +72,7 @@ resolveUsers autUser mgr UserArgs { user_id } = do
-- | Inner function to fetch the user from DB.
dbUsers :: (IsDBEnvExtra env)
=> Int -> GqlM e env [User (GqlM e env)]
dbUsers user_id = lift (map toUser <$> DBUser.getUsersWithId (Individu.RootId $ UnsafeMkNodeId user_id))
dbUsers user_id = lift (map toUser <$> runDBQuery (DBUser.getUsersWithId (Individu.RootId $ UnsafeMkNodeId user_id)))
toUser
:: (IsDBEnvExtra env)
......@@ -85,25 +85,25 @@ toUser (UserLight { .. }) = User { u_email = userLight_email
resolveHyperdata
:: (IsDBEnvExtra env)
=> UserId -> GqlM e env (Maybe HyperdataUser)
resolveHyperdata userid = lift (listToMaybe <$> DBUser.getUserHyperdata (Individu.UserDBId userid))
resolveHyperdata userid = lift (listToMaybe <$> runDBQuery (DBUser.getUserHyperdata (Individu.UserDBId userid)))
updateUserPubmedAPIKey :: ( IsDBEnvExtra env ) =>
UserPubmedAPIKeyMArgs -> GqlM' e env Int
updateUserPubmedAPIKey UserPubmedAPIKeyMArgs { user_id, api_key } = do
_ <- lift $ DBUser.updateUserPubmedAPIKey (Individu.RootId $ UnsafeMkNodeId user_id) api_key
_ <- lift $ runDBTx $ DBUser.updateUserPubmedAPIKey (Individu.RootId $ UnsafeMkNodeId user_id) api_key
pure 1
updateUserEPOAPIUser :: ( IsDBEnvExtra env ) =>
UserEPOAPIUserMArgs -> GqlM' e env Int
updateUserEPOAPIUser UserEPOAPIUserMArgs { user_id, api_user } = do
_ <- lift $ DBUser.updateUserEPOAPIUser (Individu.RootId $ UnsafeMkNodeId user_id) api_user
_ <- lift $ runDBTx $ DBUser.updateUserEPOAPIUser (Individu.RootId $ UnsafeMkNodeId user_id) api_user
pure 1
updateUserEPOAPIToken :: ( IsDBEnvExtra env ) =>
UserEPOAPITokenMArgs -> GqlM' e env Int
updateUserEPOAPIToken UserEPOAPITokenMArgs { user_id, api_token } = do
_ <- lift $ DBUser.updateUserEPOAPIToken (Individu.RootId $ UnsafeMkNodeId user_id) api_token
_ <- lift $ runDBTx $ DBUser.updateUserEPOAPIToken (Individu.RootId $ UnsafeMkNodeId user_id) api_token
pure 1
......@@ -49,7 +49,7 @@ import Gargantext.API.GraphQL.Utils (AuthStatus(Invalid, Valid), authUser)
import Gargantext.Core.Config (HasJWTSettings)
import Gargantext.Core.Types (UserId(..))
import Gargantext.Core.Types.Individu qualified as Individu
import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Query.Table.User (getUsersWithHyperdata, getUsersWithNodeHyperdata, updateUserEmail)
import Gargantext.Database.Schema.Node (node_id, node_hyperdata, NodePoly (Node, _node_id))
......@@ -124,7 +124,7 @@ updateUserInfo
=> UserInfoMArgs -> GqlM' e env Int
updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
-- lift $ printDebug "[updateUserInfo] ui_id" ui_id
users <- lift (getUsersWithNodeHyperdata (Individu.UserDBId $ UnsafeMkUserId ui_id))
users <- lift $ runDBQuery $ getUsersWithNodeHyperdata (Individu.UserDBId $ UnsafeMkUserId ui_id)
case users of
[] -> panicTrace $ "[updateUserInfo] User with id " <> (T.pack $ show ui_id) <> " doesn't exist."
((UserLight { .. }, node_u):_) -> do
......@@ -155,10 +155,11 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
let u' = UserLight { userLight_email = fromMaybe userLight_email $ view ui_cwTouchMailL u_hyperdata'
, .. }
-- lift $ printDebug "[updateUserInfo] with firstName" u_hyperdata'
_ <- lift $ updateHyperdata (node_u ^. node_id) u_hyperdata'
_ <- lift $ updateUserEmail u'
--let _newUser = toUser (u, u_hyperdata')
pure 1
lift $ runDBTx $ do
_ <- updateHyperdata (node_u ^. node_id) u_hyperdata'
_ <- updateUserEmail u'
--let _newUser = toUser (u, u_hyperdata')
pure 1
where
uh _ Nothing u_hyperdata = u_hyperdata
uh lens' (Just val) u_hyperdata = u_hyperdata & lens' ?~ val
......@@ -175,7 +176,7 @@ dbUsers user_id = do
-- user <- getUsersWithId user_id
-- hyperdata <- getUserHyperdata user_id
-- lift (map toUser <$> zip user hyperdata)
lift (map toUser <$> getUsersWithHyperdata (Individu.UserDBId user_id))
lift (map toUser <$> runDBQuery (getUsersWithHyperdata (Individu.UserDBId user_id)))
toUser :: (UserLight, HyperdataUser) -> UserInfo
toUser (UserLight { .. }, u_hyperdata) =
......
......@@ -15,6 +15,7 @@ import Gargantext.API.Routes.Named.Private qualified as Named
import Gargantext.Database.Action.Share (membersOf)
import Gargantext.Database.Admin.Types.Node (NodeType(NodeTeam))
import Gargantext.Database.Query.Table.Node (getNodesIdWithType)
import Gargantext.Database.Prelude
import Gargantext.Prelude
import Servant.Server.Generic (AsServerT)
......@@ -22,7 +23,7 @@ members :: IsGargServer err env m => Named.MembersAPI (AsServerT m)
members = Named.MembersAPI getMembers
getMembers :: IsGargServer err env m => m [Text]
getMembers = do
getMembers = runDBQuery $ do
teamNodeIds <- getNodesIdWithType NodeTeam
m <- concatMapM membersOf teamNodeIds
pure $ map fst m
......@@ -24,7 +24,7 @@ import Gargantext.API.Ngrams.NgramsTree (NgramsTree)
import Gargantext.API.Ngrams.Types (QueryParamR, TabType, ngramsTypeFromTabType, unNgramsTerm)
import Gargantext.API.Prelude (IsGargServer)
import Gargantext.API.Routes.Named.Metrics qualified as Named
import Gargantext.Core.NodeStory (HasNodeStory)
import Gargantext.Core.NodeStory (HasNodeStory, NodeStoryEnv, HasNodeStoryEnv (..))
import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeLocal)
import Gargantext.Core.Types (CorpusId, ListId, ListType(..))
import Gargantext.Core.Types.Query (Limit)
......@@ -34,7 +34,7 @@ import Gargantext.Database.Action.Metrics qualified as Metrics
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..), hl_chart, hl_pie, hl_scatter, hl_tree)
import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
......@@ -42,22 +42,28 @@ import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude hiding (hash)
import Servant
import Servant.Server.Generic (AsServerT)
import Control.Lens (view)
-------------------------------------------------------------
scatterApi :: IsGargServer err env m => NodeId -> Named.ScatterAPI (AsServerT m)
scatterApi id' = Named.ScatterAPI
{ sepGenEp = getScatter id'
{ sepGenEp = \lid tt lm -> do
env <- view hasNodeStory
runDBTx $ getScatter env id' lid tt lm
, scatterUpdateEp = updateScatter id'
, scatterHashEp = getScatterHash id'
, scatterHashEp = \a b -> do
env <- view hasNodeStory
runDBTx $ getScatterHash env id' a b
}
getScatter :: HasNodeStory env err m
=> CorpusId
getScatter :: HasNodeError err
=> NodeStoryEnv err
-> CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> m (HashedResponse Metrics)
getScatter cId maybeListId tabType _maybeLimit = do
-> DBUpdate err (HashedResponse Metrics)
getScatter env cId maybeListId tabType _maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
......@@ -68,7 +74,7 @@ getScatter cId maybeListId tabType _maybeLimit = do
chart <- case mChart of
Just chart -> pure chart
Nothing -> do
updateScatter' cId listId tabType Nothing
updateScatter' env cId listId tabType Nothing
pure $ constructHashedResponse chart
......@@ -79,24 +85,26 @@ updateScatter :: HasNodeStory env err m
-> Maybe Limit
-> m ()
updateScatter cId maybeListId tabType maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
-- printDebug "[updateScatter] cId" cId
-- printDebug "[updateScatter] maybeListId" maybeListId
-- printDebug "[updateScatter] tabType" tabType
-- printDebug "[updateScatter] maybeLimit" maybeLimit
_ <- updateScatter' cId listId tabType maybeLimit
pure ()
updateScatter' :: HasNodeStory env err m
=> CorpusId
env <- view hasNodeStory
runDBTx $ do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
-- printDebug "[updateScatter] cId" cId
-- printDebug "[updateScatter] maybeListId" maybeListId
-- printDebug "[updateScatter] tabType" tabType
-- printDebug "[updateScatter] maybeLimit" maybeLimit
void $ updateScatter' env cId listId tabType maybeLimit
updateScatter' :: HasNodeError err
=> NodeStoryEnv err
-> CorpusId
-> ListId
-> TabType
-> Maybe Limit
-> m Metrics
updateScatter' cId listId tabType maybeLimit = do
(ngs', scores) <- Metrics.getMetrics cId listId tabType maybeLimit
-> DBUpdate err Metrics
updateScatter' env cId listId tabType maybeLimit = do
(ngs', scores) <- Metrics.getMetrics env cId listId tabType maybeLimit
let
metrics = fmap (\(Scored t s1 s2) -> Metric { m_label = unNgramsTerm t
......@@ -114,31 +122,34 @@ updateScatter' cId listId tabType maybeLimit = do
pure $ Metrics metrics
getScatterHash :: HasNodeStory env err m
=> CorpusId
getScatterHash :: HasNodeError err
=> NodeStoryEnv err
-> CorpusId
-> Maybe ListId
-> TabType
-> m Text
getScatterHash cId maybeListId tabType = do
hash <$> getScatter cId maybeListId tabType Nothing
-> DBUpdate err Text
getScatterHash env cId maybeListId tabType = do
hash <$> getScatter env cId maybeListId tabType Nothing
-------------------------------------------------------------
chartApi :: IsGargServer err env m => NodeId -> Named.ChartAPI (AsServerT m)
chartApi id' = Named.ChartAPI
{ getChartEp = getChart id'
{ getChartEp = \st end ll tt -> do
runDBTx $ getChart id' st end ll tt
, updateChartEp = updateChart id'
, chartHashEp = getChartHash id'
, chartHashEp = \a b -> do
runDBTx $ getChartHash id' a b
}
-- TODO add start / end
getChart :: HasNodeStory env err m
getChart :: HasNodeError err
=> CorpusId
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe ListId
-> TabType
-> m (HashedResponse (ChartMetrics Histo))
-> DBUpdate err (HashedResponse (ChartMetrics Histo))
getChart cId _start _end maybeListId tabType = do
listId <- case maybeListId of
Just lid -> pure lid
......@@ -154,21 +165,21 @@ getChart cId _start _end maybeListId tabType = do
pure $ constructHashedResponse chart
updateChart :: HasNodeError err
updateChart :: (HasNodeError err, IsDBCmd env err m)
=> CorpusId
-> Maybe ListId
-> TabType
-> Maybe Limit
-> DBCmd err ()
-> m ()
updateChart cId maybeListId tabType maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
Nothing -> runDBQuery $ defaultList cId
printDebug "[updateChart] cId" cId
printDebug "[updateChart] listId" listId
printDebug "[updateChart] tabType" tabType
printDebug "[updateChart] maybeLimit" maybeLimit
_ <- updateChart' cId listId tabType maybeLimit
_ <- runDBTx $ updateChart' cId listId tabType maybeLimit
pure ()
updateChart' :: HasNodeError err
......@@ -176,7 +187,7 @@ updateChart' :: HasNodeError err
-> ListId
-> TabType
-> Maybe Limit
-> DBCmd err (ChartMetrics Histo)
-> DBUpdate err (ChartMetrics Histo)
updateChart' cId listId tabType _maybeLimit = do
node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
let hl = node ^. node_hyperdata
......@@ -187,11 +198,11 @@ updateChart' cId listId tabType _maybeLimit = do
pure $ ChartMetrics h
getChartHash :: HasNodeStory env err m
getChartHash :: HasNodeError err
=> CorpusId
-> Maybe ListId
-> TabType
-> m Text
-> DBUpdate err Text
getChartHash cId maybeListId tabType = do
hash <$> getChart cId Nothing Nothing maybeListId tabType
......@@ -215,19 +226,24 @@ type PieApi = Summary "Pie Chart"
pieApi :: IsGargServer err env m => NodeId -> Named.PieAPI (AsServerT m)
pieApi id' = Named.PieAPI
{ getPieChartEp = getPie id'
{ getPieChartEp = \ st end mlt tt -> do
env <- view hasNodeStory
runDBTx $ getPie env id' st end mlt tt
, pieChartUpdateEp = updatePie id'
, pieHashEp = getPieHash id'
, pieHashEp = \a b -> do
env <- view hasNodeStory
runDBTx $ getPieHash env id' a b
}
getPie :: HasNodeStory env err m
=> CorpusId
getPie :: HasNodeError err
=> NodeStoryEnv err
-> CorpusId
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe ListId
-> TabType
-> m (HashedResponse (ChartMetrics Histo))
getPie cId _start _end maybeListId tabType = do
-> DBUpdate err (HashedResponse (ChartMetrics Histo))
getPie env cId _start _end maybeListId tabType = do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
......@@ -238,7 +254,7 @@ getPie cId _start _end maybeListId tabType = do
chart <- case mChart of
Just chart -> pure chart
Nothing -> do
updatePie' cId listId tabType Nothing
updatePie' env cId listId tabType Nothing
pure $ constructHashedResponse chart
......@@ -249,58 +265,66 @@ updatePie :: HasNodeStory env err m
-> Maybe Limit
-> m ()
updatePie cId maybeListId tabType maybeLimit = do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
printDebug "[updatePie] cId" cId
printDebug "[updatePie] maybeListId" maybeListId
printDebug "[updatePie] tabType" tabType
printDebug "[updatePie] maybeLimit" maybeLimit
_ <- updatePie' cId listId tabType maybeLimit
pure ()
updatePie' :: (HasNodeStory env err m)
=> CorpusId
env <- view hasNodeStory
runDBTx $ do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
void $ updatePie' env cId listId tabType maybeLimit
updatePie' :: HasNodeError err
=> NodeStoryEnv err
-> CorpusId
-> ListId
-> TabType
-> Maybe Limit
-> m (ChartMetrics Histo)
updatePie' cId listId tabType _maybeLimit = do
-> DBUpdate err (ChartMetrics Histo)
updatePie' env cId listId tabType _maybeLimit = do
node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
let hl = node ^. node_hyperdata
pieMap = hl ^. hl_pie
p <- chartData cId (ngramsTypeFromTabType tabType) MapTerm
p <- chartData env cId (ngramsTypeFromTabType tabType) MapTerm
_ <- updateHyperdata listId $ hl { _hl_pie = HashMap.insert tabType (ChartMetrics p) pieMap }
pure $ ChartMetrics p
getPieHash :: HasNodeStory env err m
=> CorpusId
getPieHash :: HasNodeError err
=> NodeStoryEnv err
-> CorpusId
-> Maybe ListId
-> TabType
-> m Text
getPieHash cId maybeListId tabType = do
hash <$> getPie cId Nothing Nothing maybeListId tabType
-> DBUpdate err Text
getPieHash env cId maybeListId tabType = do
hash <$> getPie env cId Nothing Nothing maybeListId tabType
-------------------------------------------------------------
-- | Tree metrics API
treeApi :: IsGargServer err env m => NodeId -> Named.TreeAPI (AsServerT m)
treeApi id' = Named.TreeAPI
{ treeChartEp = getTree id'
{ treeChartEp = \st end mlid tt lt -> do
env <- view hasNodeStory
runDBTx $ getTree env id' st end mlid tt lt
, treeChartUpdateEp = updateTree id'
, treeHashEp = getTreeHash id'
, treeHashEp = \a b c -> do
env <- view hasNodeStory
runDBTx $ getTreeHash env id' a b c
}
getTree :: HasNodeStory env err m
=> CorpusId
getTree :: HasNodeError err
=> NodeStoryEnv err
-> CorpusId
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe ListId
-> TabType
-> ListType
-> m (HashedResponse (ChartMetrics (Vector NgramsTree)))
getTree cId _start _end maybeListId tabType listType = do
-> DBUpdate err (HashedResponse (ChartMetrics (Vector NgramsTree)))
getTree env cId _start _end maybeListId tabType listType = do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
......@@ -311,8 +335,7 @@ getTree cId _start _end maybeListId tabType listType = do
chart <- case mChart of
Just chart -> pure chart
Nothing -> do
updateTree' cId maybeListId tabType listType
Nothing -> updateTree' env cId maybeListId tabType listType
pure $ constructHashedResponse chart
......@@ -327,16 +350,18 @@ updateTree cId maybeListId tabType listType = do
printDebug "[updateTree] maybeListId" maybeListId
printDebug "[updateTree] tabType" tabType
printDebug "[updateTree] listType" listType
_ <- updateTree' cId maybeListId tabType listType
env <- view hasNodeStory
_ <- runDBTx $ updateTree' env cId maybeListId tabType listType
pure ()
updateTree' :: HasNodeStory env err m
=> CorpusId
updateTree' :: HasNodeError err
=> NodeStoryEnv err
-> CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m (ChartMetrics (Vector NgramsTree))
updateTree' cId maybeListId tabType listType = do
-> DBUpdate err (ChartMetrics (Vector NgramsTree))
updateTree' env cId maybeListId tabType listType = do
listId <- case maybeListId of
Just lid -> pure lid
Nothing -> defaultList cId
......@@ -344,16 +369,17 @@ updateTree' cId maybeListId tabType listType = do
node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
let hl = node ^. node_hyperdata
treeMap = hl ^. hl_tree
t <- treeData cId (ngramsTypeFromTabType tabType) listType
t <- treeData env cId (ngramsTypeFromTabType tabType) listType
_ <- updateHyperdata listId $ hl { _hl_tree = HashMap.insert tabType (ChartMetrics t) treeMap }
pure $ ChartMetrics t
getTreeHash :: HasNodeStory env err m
=> CorpusId
getTreeHash :: HasNodeError err
=> NodeStoryEnv err
-> CorpusId
-> Maybe ListId
-> TabType
-> ListType
-> m Text
getTreeHash cId maybeListId tabType listType = do
hash <$> getTree cId Nothing Nothing maybeListId tabType listType
-> DBUpdate err Text
getTreeHash env cId maybeListId tabType listType = do
hash <$> getTree env cId Nothing Nothing maybeListId tabType listType
......@@ -17,6 +17,7 @@ module Gargantext.API.Node.Corpus.Export
where
import Control.Exception.Safe qualified as CES
import Control.Lens (view)
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
......@@ -27,10 +28,12 @@ import Gargantext.API.Node.Corpus.Export.Types ( Corpus(..), CorpusSQLite(..) )
import Gargantext.API.Node.Corpus.Export.Utils (getContextNgrams, mkCorpusSQLite, mkCorpusSQLiteData)
import Gargantext.API.Node.Document.Export.Types qualified as DocumentExport
import Gargantext.API.Prelude (IsGargServer)
import Gargantext.Core.NodeStory
import Gargantext.Core.Text.Ngrams (NgramsType(..))
import Gargantext.Core.Types.Main ( ListType(MapTerm) )
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(..) )
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node ( defaultList )
import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
import Gargantext.Database.Schema.Context (_context_id)
......@@ -56,35 +59,37 @@ getCorpus cId = Named.CorpusExportAPI {
-> Maybe NgramsType
-> m (Headers '[Header "Content-Disposition" Text] Corpus)
get_corpus lId nt' = do
let
nt = fromMaybe NgramsTerms nt'
env <- view hasNodeStory
runDBQuery $ do
let
nt = fromMaybe NgramsTerms nt'
listId <- case lId of
Nothing -> defaultList cId
Just l -> pure l
listId <- case lId of
Nothing -> defaultList cId
Just l -> pure l
-- FIXME(adn) Audit the usage of this, we are converting from a node
-- to a context id.
ns <- Map.fromList
<$> map (\n -> (nodeId2ContextId $ _context_id n, n))
<$> selectDocNodes cId
-- FIXME(adn) Audit the usage of this, we are converting from a node
-- to a context id.
ns <- Map.fromList
<$> map (\n -> (nodeId2ContextId $ _context_id n, n))
<$> selectDocNodes cId
repo <- getRepo [listId]
ngs <- getContextNgrams cId listId MapTerm nt repo
let -- uniqId is hash computed already for each document imported in database
r = Map.intersectionWith
(\a b -> DocumentExport.Document { _d_document = context2node a
, _d_ngrams = DocumentExport.Ngrams (Set.toList b) (hash b)
, _d_hash = d_hash a b }
) ns (Map.map (Set.map unNgramsTerm) ngs)
where
d_hash :: Context HyperdataDocument -> Set Text -> Text
d_hash _a b = hash [ -- fromMaybe "" (_hd_uniqId $ _context_hyperdata a),
hash b
]
pure $ addHeader ("attachment; filename=GarganText_corpus-" <> pack (show cId) <> ".json")
$ Corpus { _c_corpus = Map.elems r
, _c_hash = hash $ List.map DocumentExport._d_hash $ Map.elems r }
repo <- getRepo env [listId]
ngs <- getContextNgrams cId listId MapTerm nt repo
let -- uniqId is hash computed already for each document imported in database
r = Map.intersectionWith
(\a b -> DocumentExport.Document { _d_document = context2node a
, _d_ngrams = DocumentExport.Ngrams (Set.toList b) (hash b)
, _d_hash = d_hash a b }
) ns (Map.map (Set.map unNgramsTerm) ngs)
where
d_hash :: Context HyperdataDocument -> Set Text -> Text
d_hash _a b = hash [ -- fromMaybe "" (_hd_uniqId $ _context_hyperdata a),
hash b
]
pure $ addHeader ("attachment; filename=GarganText_corpus-" <> pack (show cId) <> ".json")
$ Corpus { _c_corpus = Map.elems r
, _c_hash = hash $ List.map DocumentExport._d_hash $ Map.elems r }
getCorpusSQLite :: ( CES.MonadMask m
......
......@@ -28,6 +28,7 @@ import Gargantext.API.Prelude (IsGargServer)
import Gargantext.API.Routes.Named.Document qualified as Named
import Gargantext.Core (toDBid)
import Gargantext.Database.Admin.Types.Node (DocId, NodeId, NodeType(..))
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Facet (runViewDocuments, Facet(..))
import Gargantext.Database.Query.Table.Node (getClosestParentIdByType)
import Gargantext.Database.Query.Table.Node.User ( getNodeUser )
......@@ -64,12 +65,13 @@ getDocumentsJSON nodeUserId pId = do
get_document_json :: IsGargServer err env m => NodeId -> DocId -> m DocumentExport
get_document_json nodeUserId pId = do
uId <- view node_user_id <$> getNodeUser nodeUserId
mcId <- getClosestParentIdByType pId NodeCorpus
let cId = maybe (panicTrace "[G.A.N.D.Export] Node has no parent") identity mcId
docs <- runViewDocuments cId False Nothing Nothing Nothing Nothing Nothing
pure DocumentExport { _de_documents = mapFacetDoc uId <$> docs
, _de_garg_version = T.pack $ showVersion PG.version }
runDBQuery $ do
uId <- view node_user_id <$> getNodeUser nodeUserId
mcId <- getClosestParentIdByType pId NodeCorpus
let cId = maybe (panicTrace "[G.A.N.D.Export] Node has no parent") identity mcId
docs <- runViewDocuments cId False Nothing Nothing Nothing Nothing Nothing
pure DocumentExport { _de_documents = mapFacetDoc uId <$> docs
, _de_garg_version = T.pack $ showVersion PG.version }
where
mapFacetDoc uId (FacetDoc { .. }) =
Document { _d_document =
......
......@@ -18,6 +18,7 @@ import Gargantext.API.Routes.Named.Viz qualified as Named
import Gargantext.Core.Viz.Phylo.API.Tools (getPhyloData, phylo2dot, phylo2dot2json)
import Gargantext.Core.Viz.Phylo.Example (phyloCleopatre)
import Gargantext.Database.Admin.Types.Node (PhyloId, NodeId)
import Gargantext.Database.Prelude
import Gargantext.Prelude
import Servant
import Servant.Server.Generic (AsServerT)
......@@ -37,7 +38,7 @@ getPhyloJson :: NodeId
-> PhyloId
-> GargNoServer (Headers '[Header "Content-Disposition" T.Text] Value)
getPhyloJson _ pId = do
maybePhyloData <- getPhyloData pId
maybePhyloData <- runDBQuery $ getPhyloData pId
let phyloData = fromMaybe phyloCleopatre maybePhyloData
phyloJson <- liftBase $ phylo2dot2json phyloData
pure $ addHeader (T.concat [ "attachment; filename="
......@@ -51,7 +52,7 @@ getPhyloDot :: NodeId
-> PhyloId
-> GargNoServer (Headers '[Header "Content-Disposition" T.Text] T.Text)
getPhyloDot _ pId = do
maybePhyloData <- getPhyloData pId
maybePhyloData <- runDBQuery $ getPhyloData pId
let phyloData = fromMaybe phyloCleopatre maybePhyloData
phyloDot <- liftBase $ phylo2dot phyloData
pure $ addHeader (T.concat [ "attachment; filename="
......
......@@ -28,6 +28,7 @@ import Gargantext.Core.Types.Search (toRow)
import Gargantext.Database.Action.Flow.Pairing (isPairedWith)
import Gargantext.Database.Action.Search (searchInCorpus, searchInCorpusWithContacts)
import Gargantext.Database.Admin.Types.Node (NodeId, NodeType(..))
import Gargantext.Database.Prelude
import Gargantext.Prelude
import Gargantext.System.Logging (logLocM, LogLevel(..))
import Servant.Server.Generic (AsServerT)
......@@ -44,10 +45,10 @@ api nId = Named.SearchAPI $ \query o l order -> case query of
$(logLocM) DEBUG $ T.pack "New search started with query = " <> (getRawQuery rawQuery)
SearchResult <$> SearchResultDoc
<$> map (toRow nId)
<$> searchInCorpus nId False q o l order
<$> runDBQuery (searchInCorpus nId False q o l order)
(SearchQuery rawQuery SearchContact) -> case parseQuery rawQuery of
Left err -> pure $ SearchResult $ SearchNoResult (T.pack err)
Right q -> do
Right q -> runDBQuery $ do
-- printDebug "isPairedWith" nId
aIds <- isPairedWith nId NodeAnnuaire
-- TODO if paired with several corpus
......
......@@ -41,7 +41,7 @@ import Gargantext.Core.Types.Query (Offset, Limit)
import Gargantext.Database.Action.Learn (FavOrTrash(..), moreLike)
import Gargantext.Database.Action.Search (searchCountInCorpus, searchInCorpus)
import Gargantext.Database.Admin.Types.Node (ContactId, CorpusId, NodeId)
import Gargantext.Database.Prelude (IsDBCmdExtra, IsDBCmd, DBCmd)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Facet (FacetDoc , runViewDocuments, runCountDocuments, OrderBy(..), runViewAuthorsDoc)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Prelude
......@@ -81,7 +81,7 @@ getTableApi cId tabType mLimit mOffset mOrderBy mQuery mYear =
where
get_table = do
$(logLocM) DEBUG $ "getTable cId = " <> T.pack (show cId)
t <- getTable cId tabType mOffset mLimit mOrderBy mQuery mYear
t <- runDBQuery $ getTable cId tabType mOffset mLimit mOrderBy mQuery mYear
pure $ constructHashedResponse t
postTableApi :: (IsDBCmdExtra env err m, MonadLogger m, HasNodeError err)
......@@ -91,7 +91,7 @@ postTableApi :: (IsDBCmdExtra env err m, MonadLogger m, HasNodeError err)
postTableApi cId tq = case tq of
TableQuery o l order ft "" -> do
$(logLocM) DEBUG $ "New search with no query"
getTable cId (Just ft) (Just o) (Just l) (Just order) Nothing Nothing
runDBQuery $ getTable cId (Just ft) (Just o) (Just l) (Just order) Nothing Nothing
TableQuery o l order ft q -> case ft of
Docs -> do
$(logLocM) DEBUG $ "New search with query " <> getRawQuery q
......@@ -121,7 +121,7 @@ searchInCorpus' cId t q o l order = do
Left noParseErr -> do
$(logLocM) ERROR $ "Invalid input query " <> (getRawQuery q) <> " , error = " <> (T.pack noParseErr)
pure $ TableResult 0 []
Right boolQuery -> do
Right boolQuery -> runDBQuery $ do
docs <- searchInCorpus cId t boolQuery o l order
countAllDocs <- searchCountInCorpus cId t (Just boolQuery)
pure $ TableResult { tr_docs = docs
......@@ -136,7 +136,7 @@ getTable :: HasNodeError err
-> Maybe OrderBy
-> Maybe RawQuery
-> Maybe Text
-> DBCmd err FacetTableResult
-> DBQuery err x FacetTableResult
getTable cId ft o l order raw_query year = do
docs <- getTable' cId ft o l order query year
docsCount <- runCountDocuments cId (ft == Just Trash) query year
......@@ -152,7 +152,7 @@ getTable' :: HasNodeError err
-> Maybe OrderBy
-> Maybe Text
-> Maybe Text
-> DBCmd err [FacetDoc]
-> DBQuery err x [FacetDoc]
getTable' cId ft o l order query year =
case ft of
(Just Docs) -> runViewDocuments cId False o l order query year
......@@ -164,7 +164,7 @@ getTable' cId ft o l order query year =
getPair :: ContactId -> Maybe TabType
-> Maybe Offset -> Maybe Limit
-> Maybe OrderBy -> DBCmd err [FacetDoc]
-> Maybe OrderBy -> DBQuery err x [FacetDoc]
getPair cId ft o l order =
case ft of
(Just Docs) -> runViewAuthorsDoc cId False o l order
......
......@@ -28,7 +28,7 @@ import Gargantext.Database.Admin.Types.Node ( NodeType(NodeList), CorpusId, cont
import Gargantext.Core.Viz.Types ( Histo(Histo) )
import Gargantext.Database.Action.Metrics.NgramsByContext ( countContextsByNgramsWith, getContextsByNgramsOnlyUser )
import Gargantext.Database.Admin.Config ( userMaster )
import Gargantext.Database.Prelude (DBCmd, DBQuery, runDBQuery)
import Gargantext.Database.Prelude (DBQuery)
import Gargantext.Database.Query.Table.Node ( getListsWithParentId )
import Gargantext.Database.Query.Table.Node.Select ( selectNodesWithUsername )
import Gargantext.Database.Query.Table.NodeContext (selectDocsDates)
......@@ -36,9 +36,9 @@ import Gargantext.Database.Schema.Node ( NodePoly(_node_id) )
import Gargantext.Prelude hiding (toList)
histoData :: CorpusId -> DBCmd err Histo
histoData :: CorpusId -> DBQuery err x Histo
histoData cId = do
dates <- runDBQuery $ selectDocsDates cId
dates <- selectDocsDates cId
let (ls, css) = V.unzip
$ V.fromList
$ sortOn fst -- TODO Vector.sortOn
......
......@@ -28,6 +28,7 @@ import Gargantext.Core.Types.Phylo (GraphData(..))
import Gargantext.Core.Viz.LegacyPhylo hiding (Phylo(..))
import Gargantext.Core.Viz.Phylo (PhyloConfig(..), defaultConfig, _phylo_param, _phyloParam_config)
import Gargantext.Core.Viz.Phylo.API.Tools
import Gargantext.Database.Prelude
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Node -- (PhyloId, ListId, CorpusId, UserId, NodeId(..))
import Gargantext.Database.Query.Table.Node (getClosestParentIdByType, defaultList)
......@@ -50,12 +51,13 @@ phyloAPI n = Named.PhyloAPI
-- Add real text processing
-- Fix Filter parameters
-- TODO fix parameters to default config that should be in Node
-- NOTE(adn) this is not DB-tx safe in regards to reads.
getPhylo :: IsGargServer err env m => PhyloId -> Named.GetPhylo (AsServerT m)
getPhylo phyloId = Named.GetPhylo $ \lId _level _minSizeBranch -> do
corpusId <- maybe (nodeLookupError $ NodeParentDoesNotExist phyloId) pure
=<< getClosestParentIdByType phyloId NodeCorpus
=<< (runDBQuery $ getClosestParentIdByType phyloId NodeCorpus)
listId <- case lId of
Nothing -> defaultList corpusId
Nothing -> runDBQuery $ defaultList corpusId
Just ld -> pure ld
pd <- getPhyloDataJson phyloId
-- printDebug "getPhylo" theData
......@@ -68,7 +70,7 @@ getPhylo phyloId = Named.GetPhylo $ \lId _level _minSizeBranch -> do
getPhyloDataJson :: PhyloId -> GargNoServer (Maybe (GraphData, PhyloConfig))
getPhyloDataJson phyloId = do
phyloData <- getPhyloData phyloId
phyloData <- runDBQuery $ getPhyloData phyloId
phyloJson <- liftBase $ maybePhylo2dot2json phyloData
case phyloJson of
Nothing -> pure Nothing
......@@ -92,6 +94,8 @@ getPhyloDataJson phyloId = do
-- pure (SVG p)
-- FIXME(adn) This handler mixes DB reads with updates outside of the same
-- transaction, due to the call to 'flowPhyloAPI' in the middle.
postPhylo :: IsGargServer err env m => PhyloId -> Named.PostPhylo (AsServerT m)
postPhylo phyloId = Named.PostPhylo $ \_lId -> do
-- TODO get Reader settings
......@@ -100,12 +104,12 @@ postPhylo phyloId = Named.PostPhylo $ \_lId -> do
-- _vrs = Just ("1" :: Text)
-- _sft = Just (Software "Gargantext" "4")
-- _prm = initPhyloParam vrs sft (Just q)
corpusId <- getClosestParentIdByType phyloId NodeCorpus
corpusId <- runDBQuery $ getClosestParentIdByType phyloId NodeCorpus
-- Being the first time we ask for the Phylo, there is no historical data
-- available about computing time, so we pass 'Nothing'.
phy <- flowPhyloAPI defaultConfig Nothing (fromMaybe (panicTrace "[G.C.V.P.API] no corpus ID found") corpusId) -- params
-- phyloId <- insertNodes [node NodePhylo "Phylo" (HyperdataPhylo Nothing (Just phy)) (Just corpusId) userId]
_ <- updateHyperdata phyloId (HyperdataPhylo Nothing (Just phy))
_ <- runDBTx $ updateHyperdata phyloId (HyperdataPhylo Nothing (Just phy))
pure phyloId
------------------------------------------------------------------------
......
......@@ -34,21 +34,21 @@ data FavOrTrash = IsFav | IsTrash
moreLike :: (HasDBid NodeType, HasNodeError err)
=> CorpusId -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
-> FavOrTrash -> DBCmd err [FacetDoc]
-> FavOrTrash -> DBQuery err x [FacetDoc]
moreLike cId o _l order ft = do
priors <- getPriors ft cId
moreLikeWith cId o (Just 3) order ft priors
---------------------------------------------------------------------------
getPriors :: (HasDBid NodeType, HasNodeError err)
=> FavOrTrash -> CorpusId -> DBCmd err (Events Bool)
=> FavOrTrash -> CorpusId -> DBQuery err x (Events Bool)
getPriors ft cId = do
docs_fav <- filter (\(FacetDoc _ _ _ _ f _ _) -> f == Just 2)
<$> runDBQuery (runViewDocuments cId False Nothing Nothing Nothing Nothing Nothing)
<$> runViewDocuments cId False Nothing Nothing Nothing Nothing Nothing
docs_trash <- List.take (List.length docs_fav)
<$> runDBQuery (runViewDocuments cId True Nothing Nothing Nothing Nothing Nothing)
<$> runViewDocuments cId True Nothing Nothing Nothing Nothing Nothing
let priors = priorEventsWith text (fav2bool ft) ( List.zip (repeat False) docs_fav
......@@ -59,11 +59,11 @@ getPriors ft cId = do
moreLikeWith :: (HasDBid NodeType, HasNodeError err)
=> CorpusId -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
-> FavOrTrash -> Events Bool -> DBCmd err [FacetDoc]
-> FavOrTrash -> Events Bool -> DBQuery err x [FacetDoc]
moreLikeWith cId o l order ft priors = do
docs_test <- filter (\(FacetDoc _ _ _ _ f _ _) -> f == Just 1)
<$> runDBQuery (runViewDocuments cId False o Nothing order Nothing Nothing)
<$> runViewDocuments cId False o Nothing order Nothing Nothing
let results = map fst
$ filter ((==) (Just $ not $ fav2bool ft) . snd)
......
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