Merge branch 'dev' into dev-hackathon-fixes

CHANGELOG.md

+## 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

@@ -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

@@ -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

@@ -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,14 +119,16 @@ 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
-import qualified Data.Text as Text
-import qualified Database.PostgreSQL.Simple as PGS
+import qualified Data.Set                               as Set
+import qualified Data.Text                              as Text
+import qualified Database.PostgreSQL.Simple             as PGS
 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
 
 ------------------------------------------------------------------------
@@ -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

@@ -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,14 +192,16 @@ 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)
-                                $ view flc_scores groupedWithList
+                                 $ HashMap.filter (\g -> (view gts'_score g) > 1)
+                                 $ view flc_scores groupedWithList
 
     !(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/Group/WithStem.hs

@@ -42,7 +42,7 @@ addScoreStem :: GroupParams
              -> HashSet NgramsTerm
              -> FlowCont NgramsTerm FlowListScores
              -> FlowCont NgramsTerm FlowListScores
-addScoreStem groupParams ngrams fl = foldl' addScorePatch fl 
+addScoreStem groupParams ngrams fl = foldl' addScorePatch fl
                                    $ stemPatches groupParams ngrams
 
 ------------------------------------------------------------------------

src/Gargantext/Core/Text/List/Social.hs

@@ -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
@@ -51,8 +50,8 @@ import qualified Prelude
 -- This parameter depends on the user choice
 
 data FlowSocialListWith = FlowSocialListWithPriority { fslw_priority :: FlowSocialListPriority }
-                        | FlowSocialListWithLists    { fslw_lists :: [ListId] }
-                        | NoList { makeList :: Bool }
+                        | FlowSocialListWithLists    { fslw_lists    :: [ListId]               }
+                        | NoList                     { makeList      :: Bool                   }
 
   deriving (Eq, Show, Generic)
 instance FromJSON FlowSocialListWith where
@@ -62,7 +61,7 @@ instance FromJSON FlowSocialListWith where
     case typ of
       "MyListsFirst"     -> pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
       "OtherListsFirst"  -> pure $ FlowSocialListWithPriority { fslw_priority = OthersFirst }
-      "SelectedLists"    -> pure $ FlowSocialListWithLists { fslw_lists = value }
+      "SelectedLists"    -> pure $ FlowSocialListWithLists    { fslw_lists    = value       }
       "NoList"           -> pure $ NoList True
       _                  -> pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
   parseJSON _ = mzero
@@ -114,9 +113,9 @@ flowSocialList :: ( HasNodeStory env err m
                   -> FlowCont NgramsTerm FlowListScores
                   -> 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 (NoList _)) _u = panic "[G.C.T.L.Social] Should not be executed"
+flowSocialList (Just (FlowSocialListWithPriority p))  u = flowSocialList' p u
+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
                    , CmdM     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
-           -> [ListId]
-           -> m (Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch]))
-getHistory hist nt listes =
-  history hist [nt] listes  <$> getRepo listes
+         => [NgramsType]
+         -> [ListId]
+         -> m (Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch]))
+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

-{-|
-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

@@ -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

@@ -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