Skip to content

haskell-gargantext
haskell-gargantext
Verified Commit b3126623 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

Merge branch 'dev' into dev-hackathon-fixes

parents ed2c6313 ef6fc88c
Show whitespace changes
Inline Side-by-side
Showing with 102 additions and 150 deletions
CHANGELOG.md
View file @ b3126623
## Version 0.0.6.9.2
* [BACK][FIX] List Learning is back
* [BACK][FIX][Document rating in Doc Table is broken (#174)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/174)
* [FRONT][FIX][Document supression do not work (#495)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/495)
## Version 0.0.6.9.1
* [FRONT][FIX][terms] resolve flickering issue on children
* [FRONT][FIX] [layout] Close CTA button on graph/phylo sidebar
## Version 0.0.6.9.0
......
gargantext.cabal
View file @ b3126623
......@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: gargantext
version: 0.0.6.9.1
version: 0.0.6.9.2
synopsis: Search, map, share
description: Please see README.md
category: Data
......@@ -203,7 +203,6 @@ library
Gargantext.Core.Text.List.Merge
Gargantext.Core.Text.List.Social
Gargantext.Core.Text.List.Social.Find
Gargantext.Core.Text.List.Social.History
Gargantext.Core.Text.List.Social.Patch
Gargantext.Core.Text.List.Social.Prelude
Gargantext.Core.Text.Metrics.FrequentItemSet
......
package.yaml
View file @ b3126623
......@@ -6,7 +6,7 @@ name: gargantext
# | | | +----- Layers * : New versions with API additions
# | | | | +--- Layers * : New versions without API breaking changes
# | | | | |
version: '0.0.6.9.1'
version: '0.0.6.9.2'
synopsis: Search, map, share
description: Please see README.md
category: Data
......
src/Gargantext/Core/NodeStory.hs
View file @ b3126623
......@@ -70,7 +70,7 @@ module Gargantext.Core.NodeStory
, nse_archive_saver_immediate
, nse_var
, unNodeStory
, getNodeArchiveHistory
, getNodesArchiveHistory
, Archive(..)
, initArchive
, a_history
......@@ -93,23 +93,25 @@ module Gargantext.Core.NodeStory
where
-- import Debug.Trace (traceShow)
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Codec.Serialise.Class
import Control.Concurrent (MVar(), newMVar, modifyMVar_)
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Control.Exception (catch, throw, SomeException(..))
import Control.Lens (makeLenses, Getter, (^.), (.~), (%~), _Just, at, traverse, view)
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson hiding ((.=), decode)
import Data.ByteString.Char8 (hPutStrLn)
import Data.HashMap.Strict (HashMap)
import Data.Map.Strict (Map)
import Data.Maybe (catMaybes)
import Data.Monoid
import Data.Pool (Pool, withResource)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Data.Semigroup
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import GHC.Generics (Generic)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (ListId, NodeId(..), NodeType)
......@@ -117,9 +119,11 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Prelude (CmdM', HasConnectionPool(..), HasConfig)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Prelude
import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
import System.IO (stderr)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import qualified Data.Map.Strict.Patch as PM
import qualified Data.Set as Set
......@@ -253,8 +257,6 @@ initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
]
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | Lenses at the bottom of the file because Template Haskell would reorder order of execution in others cases
makeLenses ''NodeStoryEnv
......@@ -288,7 +290,8 @@ type ArchiveList = Archive NgramsState' NgramsStatePatch'
-- DB stuff
runPGSExecute :: (PGS.ToRow q) => PGS.Connection -> PGS.Query -> q -> IO Int64
runPGSExecute :: (PGS.ToRow q)
=> PGS.Connection -> PGS.Query -> q -> IO Int64
runPGSExecute c qs a = catch (PGS.execute c qs a) printError
where
printError (SomeException e) = do
......@@ -296,7 +299,8 @@ runPGSExecute c qs a = catch (PGS.execute c qs a) printError
_ <- panic $ Text.pack $ show e
throw (SomeException e)
runPGSExecuteMany :: (PGS.ToRow q) => PGS.Connection -> PGS.Query -> [q] -> IO Int64
runPGSExecuteMany :: (PGS.ToRow q)
=> PGS.Connection -> PGS.Query -> [q] -> IO Int64
runPGSExecuteMany c qs a = catch (PGS.executeMany c qs a) printError
where
printError (SomeException e) = do
......@@ -304,7 +308,8 @@ runPGSExecuteMany c qs a = catch (PGS.executeMany c qs a) printError
_ <- panic $ Text.pack $ show e
throw (SomeException e)
runPGSQuery :: (PGS.FromRow r, PGS.ToRow q) => PGS.Connection -> PGS.Query -> q -> IO [r]
runPGSQuery :: (PGS.FromRow r, PGS.ToRow q)
=> PGS.Connection -> PGS.Query -> q -> IO [r]
runPGSQuery c q a = catch (PGS.query c q a) printError
where
printError (SomeException e) = do
......@@ -314,22 +319,26 @@ runPGSQuery c q a = catch (PGS.query c q a) printError
runPGSAdvisoryLock :: PGS.Connection -> Int -> IO ()
runPGSAdvisoryLock c id = do
_ <- runPGSQuery c [sql| SELECT pg_advisory_lock(?) |] (PGS.Only id) :: IO [PGS.Only ()]
_ <- runPGSQuery c [sql| SELECT pg_advisory_lock(?) |]
(PGS.Only id) :: IO [PGS.Only ()]
pure ()
runPGSAdvisoryUnlock :: PGS.Connection -> Int -> IO ()
runPGSAdvisoryUnlock c id = do
_ <- runPGSQuery c [sql| SELECT pg_advisory_unlock(?) |] (PGS.Only id) :: IO [PGS.Only Bool]
_ <- runPGSQuery c [sql| SELECT pg_advisory_unlock(?) |]
(PGS.Only id) :: IO [PGS.Only Bool]
pure ()
runPGSAdvisoryXactLock :: PGS.Connection -> Int -> IO ()
runPGSAdvisoryXactLock c id = do
_ <- runPGSQuery c [sql| SELECT pg_advisory_xact_lock(?) |] (PGS.Only id) :: IO [PGS.Only ()]
_ <- runPGSQuery c [sql| SELECT pg_advisory_xact_lock(?) |]
(PGS.Only id) :: IO [PGS.Only ()]
pure ()
nodeExists :: PGS.Connection -> NodeId -> IO Bool
nodeExists c nId = (== [PGS.Only True])
<$> runPGSQuery c [sql| SELECT true FROM nodes WHERE id = ? LIMIT 1 |] (PGS.Only nId)
<$> runPGSQuery c [sql| SELECT true FROM nodes WHERE id = ? LIMIT 1 |]
(PGS.Only nId)
getNodesIdWithType :: PGS.Connection -> NodeType -> IO [NodeId]
getNodesIdWithType c nt = do
......@@ -340,38 +349,34 @@ getNodesIdWithType c nt = do
query = [sql| SELECT id FROM nodes WHERE typename = ? |]
-- nodeStoryTable :: Table NodeStoryRead NodeStoryWrite
-- nodeStoryTable =
-- Table "node_stories"
-- ( pNodeStory NodeStoryDB { node_id = tableField "node_id"
-- , version = tableField "version"
-- , ngrams_type_id = tableField "ngrams_type_id"
-- , ngrams_id = tableField "ngrams_id"
-- , ngrams_repo_element = tableField "ngrams_repo_element"
-- } )
-- nodeStoryArchiveTable :: Table NodeStoryArchiveRead NodeStoryArchiveWrite
-- nodeStoryArchiveTable =
-- Table "node_story_archive_history"
-- ( pNodeArchiveStory NodeStoryArchiveDB { a_node_id = tableField "node_id"
-- , archive = tableField "archive" } )
-- nodeStorySelect :: Select NodeStoryRead
-- nodeStorySelect = selectTable nodeStoryTable
-- NOTE "first patch in the _a_history list is the most recent"
getNodeArchiveHistory :: PGS.Connection -> NodeId -> IO [NgramsStatePatch']
getNodeArchiveHistory c nodeId = do
as <- runPGSQuery c query (PGS.Only nodeId) :: IO [(TableNgrams.NgramsType, NgramsTerm, NgramsPatch)]
pure $ (\(ngramsType, terms, patch) -> fst $ PM.singleton ngramsType (NgramsTablePatch $ fst $ PM.singleton terms patch)) <$> as
-- /!\ This function is using an hard coded parameter
-- which depends on the Ngrams List Flow
-- Version > 5 is hard coded because by default
-- first version of history of manual change is 6
getNodesArchiveHistory :: PGS.Connection
-> [NodeId]
-> IO [(NodeId, (Map NgramsType [HashMap NgramsTerm NgramsPatch]))]
getNodesArchiveHistory c nodesId = do
as <- runPGSQuery c query (PGS.Only $ Values fields nodesId)
:: IO [(Int, TableNgrams.NgramsType, NgramsTerm, NgramsPatch)]
pure $ map (\(nId, ngramsType, terms, patch)
-> ( NodeId nId
, Map.singleton ngramsType [HashMap.singleton terms patch]
)
) as
where
fields = [QualifiedIdentifier Nothing "int4"]
query :: PGS.Query
query = [sql| SELECT ngrams_type_id, terms, patch
query = [sql| WITH nodes_id(nid) as (?)
SELECT node_id, ngrams_type_id, terms, patch
FROM node_story_archive_history
JOIN ngrams ON ngrams.id = ngrams_id
WHERE node_id = ?
ORDER BY (version, node_story_archive_history.id) DESC |]
JOIN nodes_id n ON node_id = n.nid
WHERE version > 5
ORDER BY (version, node_story_archive_history.id) DESC
|]
ngramsIdQuery :: PGS.Query
ngramsIdQuery = [sql| SELECT id FROM ngrams WHERE terms = ? |]
......
src/Gargantext/Core/Text/List.hs
View file @ b3126623
......@@ -179,7 +179,10 @@ buildNgramsTermsList user uCid mCid mfslw groupParams (nt, MapListSize mapListSi
)
printDebug "[buildNgramsTermsList: Flow Social List / end]" nt
let !ngramsKeys = HashSet.fromList $ List.take mapListSize $ HashSet.toList $ HashMap.keysSet allTerms
let !ngramsKeys = HashSet.fromList
$ List.take mapListSize
$ HashSet.toList
$ HashMap.keysSet allTerms
printDebug "[buildNgramsTermsList: ngramsKeys]" (HashSet.size ngramsKeys)
......@@ -189,7 +192,6 @@ buildNgramsTermsList user uCid mCid mfslw groupParams (nt, MapListSize mapListSi
let
!socialLists_Stemmed = addScoreStem groupParams' ngramsKeys socialLists
--printDebug "socialLists_Stemmed" socialLists_Stemmed
!groupedWithList = toGroupedTree socialLists_Stemmed allTerms
!(stopTerms, candidateTerms) = HashMap.partition ((== Just StopTerm) . viewListType)
$ HashMap.filter (\g -> (view gts'_score g) > 1)
......@@ -197,6 +199,9 @@ buildNgramsTermsList user uCid mCid mfslw groupParams (nt, MapListSize mapListSi
!(groupedMono, groupedMult) = HashMap.partitionWithKey (\(NgramsTerm t) _v -> size t < 2) candidateTerms
printDebug "[buildNgramsTermsList] socialLists" socialLists
printDebug "[buildNgramsTermsList] socialLists with scores" socialLists_Stemmed
printDebug "[buildNgramsTermsList] groupedWithList" groupedWithList
printDebug "[buildNgramsTermsList] stopTerms" stopTerms
-- splitting monterms and multiterms to take proportional candidates
......
src/Gargantext/Core/Text/List/Social.hs
View file @ b3126623
......@@ -13,35 +13,34 @@ Portability : POSIX
module Gargantext.Core.Text.List.Social
where
import Control.Lens (view)
import Control.Monad (mzero)
import Data.Aeson
import Data.HashMap.Strict (HashMap)
import Data.Map (Map)
import Data.Monoid (mconcat)
import Data.Pool
import Data.Swagger
import GHC.Generics
import Web.Internal.HttpApiData (ToHttpApiData, FromHttpApiData, parseUrlPiece, toUrlPiece)
import qualified Data.Scientific as Scientific
import qualified Data.Text as T
import qualified Data.Vector as V
import Gargantext.API.Ngrams.Tools (getRepo)
import Gargantext.API.Ngrams.Types (NgramsTerm, NgramsPatch)
import Gargantext.Core.NodeStory (HasNodeStory)
import Gargantext.Core.NodeStory (HasNodeStory, getNodesArchiveHistory)
import Gargantext.Core.Text.List.Social.Find (findListsId)
import Gargantext.Core.Text.List.Social.History (History(..), history)
import Gargantext.Core.Text.List.Social.Patch (addScorePatches)
import Gargantext.Core.Text.List.Social.Prelude (FlowCont, FlowListScores)
import Gargantext.Core.Types.Individu (User)
import Gargantext.Database.Admin.Types.Node (ListId, NodeId(..))
import Gargantext.Database.Prelude (CmdM)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Tree (NodeMode(Private), HasTreeError)
import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Prelude
import Web.Internal.HttpApiData (ToHttpApiData, FromHttpApiData, parseUrlPiece, toUrlPiece)
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Scientific as Scientific
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Prelude
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | Main parameters
......@@ -115,7 +114,7 @@ flowSocialList :: ( HasNodeStory env err m
-> m (FlowCont NgramsTerm FlowListScores)
flowSocialList Nothing u = flowSocialList' MySelfFirst u
flowSocialList (Just (FlowSocialListWithPriority p)) u = flowSocialList' p u
flowSocialList (Just (FlowSocialListWithLists ls)) _ = getHistoryScores ls History_User
flowSocialList (Just (FlowSocialListWithLists ls)) _ = getHistoryScores ls
flowSocialList (Just (NoList _)) _u = panic "[G.C.T.L.Social] Should not be executed"
flowSocialList' :: ( HasNodeStory env err m
......@@ -156,7 +155,7 @@ flowSocialList' flowPriority user nt flc =
-> [ListId]
-> m (FlowCont NgramsTerm FlowListScores)
flowSocialListByModeWith nt'' flc'' listes =
getHistoryScores listes History_User nt'' flc''
getHistoryScores listes nt'' flc''
-----------------------------------------------------------------
......@@ -166,21 +165,25 @@ getHistoryScores :: ( HasNodeStory env err m
, HasTreeError err
)
=> [ListId]
-> History
-> NgramsType
-> FlowCont NgramsTerm FlowListScores
-> m (FlowCont NgramsTerm FlowListScores)
getHistoryScores lists hist nt fl =
addScorePatches nt lists fl <$> getHistory hist nt lists
getHistoryScores lists nt fl =
addScorePatches nt lists fl <$> getHistory [nt] lists
getHistory :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> History
-> NgramsType
=> [NgramsType]
-> [ListId]
-> m (Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch]))
getHistory hist nt listes =
history hist [nt] listes <$> getRepo listes
getHistory types listsId = do
pool <- view connPool
nsp <- liftBase $ withResource pool $ \c -> getNodesArchiveHistory c listsId
pure $ Map.map (Map.filterWithKey (\k _ -> List.elem k types))
$ Map.filterWithKey (\k _ -> List.elem k listsId)
$ Map.fromListWith (Map.unionWith (<>)) nsp
src/Gargantext/Core/Text/List/Social/History.hs deleted 100644 → 0
View file @ ed2c6313
{-|
Module : Gargantext.Core.Text.List.Social.History
Description :
Copyright : (c) CNRS, 2018-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
module Gargantext.Core.Text.List.Social.History
where
import Control.Lens hiding (cons)
import Data.HashMap.Strict (HashMap)
import Data.Map (Map)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Types (ListId)
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Prelude
import qualified Data.List as List
import qualified Data.Map.Strict as Map
-- TODO put this in Prelude
cons :: a -> [a]
cons a = [a]
------------------------------------------------------------------------
-- | History control
data History = History_User
| History_NotUser
| History_All
------------------------------------------------------------------------
-- | Main Function
history :: History
-> [NgramsType]
-> [ListId]
-> NodeStory s NgramsStatePatch'
-> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
history History_User t l = clean . (history' t l)
where
clean = Map.map (Map.map List.init)
history History_NotUser t l = clean . (history' t l)
where
clean = Map.map (Map.map last)
last = (maybe [] cons) . lastMay
history _ t l = history' t l
------------------------------------------------------------------------
history' :: [NgramsType]
-> [ListId]
-> NodeStory s NgramsStatePatch'
-> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
history' types lists = (Map.map (Map.unionsWith (<>)))
. (Map.map (map (Map.filterWithKey (\k _ -> List.elem k types))))
. (Map.map (map toMap))
. (Map.map (view a_history))
. (Map.filterWithKey (\k _ -> List.elem k lists))
. (view unNodeStory)
where
toMap :: PatchMap NgramsType NgramsTablePatch
-> Map NgramsType [HashMap NgramsTerm NgramsPatch]
toMap m = Map.map (cons . unNgramsTablePatch)
$ unPatchMapToMap m
src/Gargantext/Core/Text/List/Social/Patch.hs
View file @ b3126623
......@@ -37,7 +37,6 @@ addScorePatches nt listes fl repo =
addScorePatchesList :: NgramsType
-- -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
-> FlowCont NgramsTerm FlowListScores
-> ListId
......
src/Gargantext/Database/Admin/Types/Node.hs
View file @ b3126623
......@@ -19,6 +19,7 @@ Portability : POSIX
module Gargantext.Database.Admin.Types.Node
where
import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
import Codec.Serialise (Serialise())
import Control.Monad (mzero)
import Data.Aeson
......@@ -217,6 +218,9 @@ instance Show NodeId where
instance Serialise NodeId
instance ToField NodeId where
toField (NodeId n) = toField n
instance ToRow NodeId where
toRow (NodeId i) = [toField i]
instance FromField NodeId where
fromField field mdata = do
n <- fromField field mdata
......
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