Merge branch 'dev' into dev-phylo

bin/gargantext-import/Main.hs

@@ -14,18 +14,21 @@ Import a corpus binary.
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE Strict            #-}
 
 module Main where
 
+import Control.Exception (finally)
 import Servant (ServantErr)
 import Gargantext.Prelude
-import Gargantext.Database.Flow (flowCorpus)
+import Gargantext.Database.Flow (FlowCmdM, flowCorpus)
 import Gargantext.Text.Parsers (FileFormat(CsvHalFormat))
-import Gargantext.Database.Utils (Cmd, connectGargandb, runCmdDevWith)
-import Gargantext.Database.Types.Node (NodeId)
+import Gargantext.Database.Utils (Cmd, )
+import Gargantext.Database.Types.Node (CorpusId)
 --import Gargantext.Database.Schema.User (insertUsers, gargantuaUser, simpleUser)
 import Gargantext.API.Node () -- instances
+import Gargantext.API.Settings (newDevEnvWith, runCmdDev, DevEnv)
 import System.Environment (getArgs)
 
 main :: IO ()
@@ -34,11 +37,16 @@ main = do
 
   {-let createUsers :: Cmd ServantErr Int64
       createUsers = insertUsers [gargantuaUser,simpleUser]
-  _ <- runCmdDevWith iniPath createUsers
   -}
-  let cmd :: Cmd ServantErr NodeId
-      cmd = flowCorpus CsvHalFormat corpusPath (cs name)
-  r <- runCmdDevWith iniPath cmd
+
+  let cmdCorpus :: forall m. FlowCmdM DevEnv ServantErr m => m CorpusId
+      cmdCorpus = flowCorpus CsvHalFormat corpusPath (cs name)
+
+     -- cmd = {-createUsers >>-} cmdCorpus
+
+  env <- newDevEnvWith iniPath
+  -- Better if we keep only one call to runCmdDev.
+  _ <- runCmdDev env cmdCorpus
   pure ()
 
 

bin/gargantext-server/Main.hs

@@ -44,40 +44,37 @@ instance ParseField  Mode
 instance ParseFields Mode
 
 
-data MyOptions w = MyOptions { run  :: w ::: Mode        <?> "Possible modes: Dev | Mock | Prod"
-                             , port :: w ::: Maybe Int   <?> "By default: 8008"
-                             , ini  :: w ::: Maybe Text  <?> "Ini-file path of gargantext.ini"
-                             }
-          deriving (Generic)
+data MyOptions w =
+  MyOptions { run  :: w ::: Mode
+                        <?> "Possible modes: Dev | Mock | Prod"
+            , port :: w ::: Maybe Int
+                        <?> "By default: 8008"
+            , ini  :: w ::: Maybe Text
+                        <?> "Ini-file path of gargantext.ini"
+            }
+   deriving (Generic)
 
 instance ParseRecord (MyOptions Wrapped)
 deriving instance Show (MyOptions Unwrapped)
 
 
-
 main :: IO ()
-main = do 
-    MyOptions myMode myPort myIniFile  <- unwrapRecord
-            "Gargantext: collaborative platform for text-mining"
-
-    let myPort' = case myPort of
-            Just p  -> p
-            Nothing -> 8008
-
-    let start = case myMode of
-            --Nothing   -> startGargantext myPort' (unpack myIniFile')
-            Prod -> startGargantext myPort' (unpack myIniFile')
-                    where
-                        myIniFile' = case myIniFile of
-                                       Nothing -> panic "For Prod mode, you need to fill a gargantext.ini file"
-                                       Just i  -> i
-            Mock -> startGargantextMock myPort'
-            _  -> startGargantextMock myPort'
-
-    putStrLn $ "Starting Gargantext with mode: " <> show myMode
-    start
-
--- main' :: IO ()
---main' = putStrLn $ show $ M.conditional $ M.myMat 10
-
+main = do
+  MyOptions myMode myPort myIniFile  <- unwrapRecord
+          "Gargantext server"
+
+  let myPort' = case myPort of
+        Just p  -> p
+        Nothing -> 8008
+
+  let start = case myMode of
+        Prod -> startGargantext myPort' (unpack myIniFile')
+            where
+              myIniFile' = case myIniFile of
+                  Nothing -> panic "[ERROR] gargantext.ini needed"
+                  Just i  -> i
+        _ -> startGargantextMock myPort'
+
+  putStrLn $ "Starting with " <> show myMode <> " mode."
+  start
 

package.yaml

@@ -28,6 +28,7 @@ library:
   - Gargantext.API.Auth
   - Gargantext.API.Count
   - Gargantext.API.FrontEnd
+  - Gargantext.API.Ngrams
   - Gargantext.API.Node
   - Gargantext.API.Orchestrator
   - Gargantext.API.Search
@@ -50,6 +51,7 @@ library:
   - Gargantext.Text.Examples
   - Gargantext.Text.List.CSV
   - Gargantext.Text.Metrics
+  - Gargantext.Text.Metrics.TFICF
   - Gargantext.Text.Metrics.CharByChar
   - Gargantext.Text.Metrics.Count
   - Gargantext.Text.Parsers
@@ -109,6 +111,7 @@ library:
   - ini
   - insert-ordered-containers
   - jose-jwt
+  - json-state
     #  - kmeans-vector
   - KMP
   - lens
@@ -159,11 +162,13 @@ library:
   - text-metrics
   - time
   - time-locale-compat
+  - time-units
   - timezone-series
   - transformers
   - transformers-base
   - unordered-containers
   - uuid
+  - validity
   - vector
   - wai
   - wai-cors

src/Gargantext/API.hs

@@ -44,6 +44,7 @@ import           GHC.Generics (D1, Meta (..), Rep)
 import           GHC.TypeLits (AppendSymbol, Symbol)
 
 import           Control.Lens
+import           Control.Exception (finally)
 import           Control.Monad.IO.Class (liftIO)
 import           Control.Monad.Reader (runReaderT)
 import           Data.Aeson.Encode.Pretty (encodePretty)
@@ -72,6 +73,7 @@ import Gargantext.Prelude
 import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
 
 import Gargantext.API.Auth (AuthRequest, AuthResponse, auth)
+import Gargantext.API.Ngrams (HasRepoVar(..), HasRepoSaver(..), saveRepo)
 import Gargantext.API.Node ( GargServer
                            , Roots    , roots
                            , NodeAPI  , nodeAPI
@@ -83,6 +85,7 @@ import Gargantext.API.Node ( GargServer
                            , HyperdataAnnuaire
                            )
 --import Gargantext.Database.Node.Contact (HyperdataContact)
+import Gargantext.Database.Utils (HasConnection)
 import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
 import Gargantext.API.Count  ( CountAPI, count, Query)
 import Gargantext.API.Search ( SearchAPI, search, SearchQuery)
@@ -163,9 +166,8 @@ makeMockApp env = do
 
 
 
-makeDevApp :: Env -> IO Application
-makeDevApp env = do
-    serverApp <- makeApp env
+makeDevMiddleware :: IO Middleware
+makeDevMiddleware = do
 
     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
@@ -192,8 +194,8 @@ makeDevApp env = do
     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
     --          $ Warp.defaultSettings
     
-    --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
-    pure $ logStdoutDev $ corsMiddleware $ serverApp
+    --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
+    pure $ logStdoutDev . corsMiddleware
 
 ---------------------------------------------------------------------
 -- | API Global
@@ -276,12 +278,13 @@ type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html
 ---------------------------------------------------------------------
 -- | Server declarations
 
-server :: Env -> IO (Server API)
+server :: (HasConnection env, HasRepoVar env, HasRepoSaver env)
+       => env -> IO (Server API)
 server env = do
   -- orchestrator <- scrapyOrchestrator env
   pure $  swaggerFront
      :<|> hoistServer (Proxy :: Proxy GargAPI) (`runReaderT` env) serverGargAPI
-     :<|> serverIndex
+     :<|> serverStatic
 
 serverGargAPI :: GargServer GargAPI
 serverGargAPI -- orchestrator
@@ -299,9 +302,12 @@ serverGargAPI -- orchestrator
   where
     fakeUserId = 1 -- TODO
 
-serverIndex :: Server (Get '[HTML] Html)
-serverIndex = $(do (Just s) <- liftIO (fileTypeToFileTree (FileTypeFile "purescript-gargantext/dist/index.html"))
-                   fileTreeToServer s)
+serverStatic :: Server (Get '[HTML] Html)
+serverStatic = $(do
+                let path = "purescript-gargantext/dist/index.html"
+                Just s <- liftIO (fileTypeToFileTree (FileTypeFile path))
+                fileTreeToServer s
+                )
 
 ---------------------------------------------------------------------
 swaggerFront :: Server SwaggerFrontAPI
@@ -312,11 +318,12 @@ gargMock :: Server GargAPI
 gargMock = mock apiGarg Proxy
 
 ---------------------------------------------------------------------
-makeApp :: Env -> IO Application
+makeApp :: (HasConnection env, HasRepoVar env, HasRepoSaver env) 
+        => env -> IO Application
 makeApp = fmap (serve api) . server
 
 appMock :: Application
-appMock = serve api (swaggerFront :<|> gargMock :<|> serverIndex)
+appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 
 ---------------------------------------------------------------------
 api :: Proxy API
@@ -367,13 +374,19 @@ portRouteInfo port = do
   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 
+stopGargantext :: HasRepoSaver env => env -> IO ()
+stopGargantext env = do
+  T.putStrLn "----- Stopping gargantext -----"
+  runReaderT saveRepo env
+
 -- | startGargantext takes as parameters port number and Ini file.
 startGargantext :: PortNumber -> FilePath -> IO ()
 startGargantext port file = do
   env <- newEnv port file
   portRouteInfo port
-  app <- makeDevApp env
-  run port app
+  app <- makeApp env
+  mid <- makeDevMiddleware
+  run port (mid app) `finally` stopGargantext env
 
 startGargantextMock :: PortNumber -> IO ()
 startGargantextMock port = do

src/Gargantext/API/Ngrams.hs

@@ -15,6 +15,7 @@ add get
 
 -}
 
+{-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE NoImplicitPrelude #-}
@@ -22,49 +23,64 @@ add get
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeOperators     #-}
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE TypeFamilies      #-}
 {-# OPTIONS -fno-warn-orphans #-}
 
 module Gargantext.API.Ngrams
   where
 
-import Prelude (round)
+import Debug.Trace (trace)
+import Prelude (Enum, Bounded, Semigroup(..), minBound, maxBound {-, round-}, error)
 -- import Gargantext.Database.Schema.User  (UserId)
 import Data.Functor (($>))
-import Data.Patch.Class (Replace, replace, new)
---import qualified Data.Map.Strict.Patch as PM
+import Data.Patch.Class (Replace, replace, Action(act), Applicable(..),
+                         Composable(..), Transformable(..),
+                         PairPatch(..), Patched, ConflictResolution,
+                         ConflictResolutionReplace, ours)
+import qualified Data.Map.Strict.Patch as PM
 import Data.Monoid
 --import Data.Semigroup
 import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Maybe (isJust)
-import Data.Tuple.Extra (first)
--- import qualified Data.Map.Strict as DM
-import Data.Map.Strict (Map, mapKeys, fromListWith)
+-- import qualified Data.List as List
+import Data.Maybe (catMaybes)
+-- import Data.Tuple.Extra (first)
+import qualified Data.Map.Strict as Map
+import Data.Map.Strict (Map)
 --import qualified Data.Set as Set
-import Control.Lens (makeLenses, Prism', prism', (^..), (.~), (#), to, withIndex, folded, ifolded)
+import Control.Category ((>>>))
+import Control.Concurrent
+import Control.Lens (makeLenses, makePrisms, Getter, Prism', prism', Iso', iso, from, (^..), (.~), (#), to, {-withIndex, folded, ifolded,-} view, (^.), (+~), (%~), at, _Just, Each(..), itraverse_, (.=), both, mapped)
 import Control.Monad (guard)
 import Control.Monad.Error.Class (MonadError, throwError)
-import Data.Aeson
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Aeson hiding ((.=))
 import Data.Aeson.TH (deriveJSON)
 import Data.Either(Either(Left))
-import Data.Map (lookup)
+-- import Data.Map (lookup)
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 import Data.Swagger hiding (version, patch)
 import Data.Text (Text)
+import Data.Validity
 import GHC.Generics (Generic)
 import Gargantext.Core.Utils.Prefix (unPrefix)
-import Gargantext.Database.Types.Node (NodeType(..))
-import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
-import Gargantext.Database.Schema.Ngrams (NgramsType, NgramsTypeId, ngramsTypeId, NgramsTableData(..))
+-- import Gargantext.Database.Schema.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..))
+import Gargantext.Database.Config (userMaster)
+import Gargantext.Database.Schema.Ngrams (NgramsType)
+import Gargantext.Database.Utils (fromField', HasConnection)
+import Gargantext.Database.Lists (listsWith)
+import Gargantext.Database.Schema.Node (HasNodeError)
+import Database.PostgreSQL.Simple.FromField (FromField, fromField)
 import qualified Gargantext.Database.Schema.Ngrams as Ngrams
-import Gargantext.Database.Schema.NodeNgram
-import Gargantext.Database.Utils (Cmd)
+-- import Gargantext.Database.Schema.NodeNgram hiding (Action)
 import Gargantext.Prelude
-import Gargantext.Core.Types (ListType(..), ListTypeId, ListId, CorpusId, Limit, Offset, listTypeId)
-import Prelude (Enum, Bounded, minBound, maxBound)
+-- import Gargantext.Core.Types (ListTypeId, listTypeId)
+import Gargantext.Core.Types (ListType(..), NodeId, ListId, CorpusId, Limit, Offset)
 import Servant hiding (Patch)
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
@@ -96,6 +112,25 @@ instance Arbitrary TabType
   where
     arbitrary = elements [minBound .. maxBound]
 
+newtype MSet a = MSet (Map a ())
+  deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid)
+
+instance ToJSON a => ToJSON (MSet a) where
+  toJSON     (MSet m) = toJSON     (Map.keys m)
+  toEncoding (MSet m) = toEncoding (Map.keys m)
+
+mSetFromSet :: Set a -> MSet a
+mSetFromSet = MSet . Map.fromSet (const ())
+
+mSetFromList :: Ord a => [a] -> MSet a
+mSetFromList = MSet . Map.fromList . map (\x -> (x, ()))
+
+instance (Ord a, FromJSON a) => FromJSON (MSet a) where
+  parseJSON = fmap mSetFromList . parseJSON
+
+instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
+  -- TODO
+
 ------------------------------------------------------------------------
 type NgramsTerm = Text
 
@@ -104,7 +139,7 @@ data NgramsElement =
                    , _ne_list        :: ListType
                    , _ne_occurrences :: Int
                    , _ne_parent      :: Maybe NgramsTerm
-                   , _ne_children    :: Set NgramsTerm
+                   , _ne_children    :: MSet NgramsTerm
                    }
       deriving (Ord, Eq, Show, Generic)
 
@@ -116,10 +151,21 @@ instance Arbitrary NgramsElement where
   arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
 
 ------------------------------------------------------------------------
-newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
+newtype NgramsTable = NgramsTable [NgramsElement]
   deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 
+type ListNgrams = NgramsTable
+
+makePrisms ''NgramsTable
+
+-- | Question: why these repetition of Type in this instance
+-- may you document it please ?
+instance Each NgramsTable NgramsTable NgramsElement NgramsElement where
+  each = _NgramsTable . each
+
+-- TODO discuss
 -- | TODO Check N and Weight
+{-
 toNgramsElement :: [NgramsTableData] -> [NgramsElement]
 toNgramsElement ns = map toNgramsElement' ns
     where
@@ -132,35 +178,40 @@ toNgramsElement ns = map toNgramsElement' ns
           lt' = maybe (panic "API.Ngrams: listypeId") identity lt
       
       mapParent :: Map Int Text
-      mapParent   = fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
+      mapParent   = Map.fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
       
       mapChildren :: Map Text (Set Text)
-      mapChildren = mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
-                  $ fromListWith (<>)
+      mapChildren = Map.mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
+                  $ Map.fromListWith (<>)
                   $ map (first fromJust)
                   $ filter (isJust . fst)
                   $ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns
+-}
 
+mockTable :: NgramsTable
+mockTable = NgramsTable
+  [ NgramsElement "animal"  GraphList     1  Nothing       (mSetFromList ["dog", "cat"])
+  , NgramsElement "cat"     GraphList     1 (Just "animal") mempty
+  , NgramsElement "cats"    StopList      4  Nothing        mempty
+  , NgramsElement "dog"     GraphList     3 (Just "animal")(mSetFromList ["dogs"])
+  , NgramsElement "dogs"    StopList      4 (Just "dog")    mempty
+  , NgramsElement "fox"     GraphList     1  Nothing        mempty
+  , NgramsElement "object"  CandidateList 2  Nothing        mempty
+  , NgramsElement "nothing" StopList      4  Nothing        mempty
+  , NgramsElement "organic" GraphList     3  Nothing        (mSetFromList ["flower"])
+  , NgramsElement "flower"  GraphList     3 (Just "organic") mempty
+  , NgramsElement "moon"    CandidateList 1  Nothing         mempty
+  , NgramsElement "sky"     StopList      1  Nothing         mempty
+  ]
 
 instance Arbitrary NgramsTable where
-  arbitrary = elements
-              [ NgramsTable
-                [ NgramsElement "animal"  GraphList     1  Nothing       (Set.fromList ["dog", "cat"])
-                , NgramsElement "cat"     GraphList     1 (Just "animal") mempty
-                , NgramsElement "cats"    StopList      4  Nothing        mempty
-                , NgramsElement "dog"     GraphList     3 (Just "animal")(Set.fromList ["dogs"])
-                , NgramsElement "dogs"    StopList      4 (Just "dog")    mempty
-                , NgramsElement "fox"     GraphList     1  Nothing        mempty
-                , NgramsElement "object"  CandidateList 2  Nothing        mempty
-                , NgramsElement "nothing" StopList      4  Nothing        mempty
-                , NgramsElement "organic" GraphList     3  Nothing        (Set.singleton "flower")
-                , NgramsElement "flower"  GraphList     3 (Just "organic") mempty
-                , NgramsElement "moon"    CandidateList 1  Nothing         mempty
-                , NgramsElement "sky"     StopList      1  Nothing         mempty
-                ]
-              ]
+  arbitrary = pure mockTable
+
 instance ToSchema NgramsTable
 
+------------------------------------------------------------------------
+type NgramsTableMap = Map NgramsTerm NgramsElement
+
 ------------------------------------------------------------------------
 -- On the Client side:
 --data Action = InGroup     NgramsId NgramsId
@@ -173,8 +224,8 @@ data PatchSet a = PatchSet
   }
   deriving (Eq, Ord, Show, Generic)
 
-instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
-  arbitrary = PatchSet <$> arbitrary <*> arbitrary
+makeLenses ''PatchSet
+makePrisms ''PatchSet
 
 instance ToJSON a => ToJSON (PatchSet a) where
   toJSON     = genericToJSON     $ unPrefix "_"
@@ -183,7 +234,106 @@ instance ToJSON a => ToJSON (PatchSet a) where
 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
   parseJSON = genericParseJSON $ unPrefix "_"
 
+{-
+instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
+  arbitrary = PatchSet <$> arbitrary <*> arbitrary
+
+type instance Patched (PatchSet a) = Set a
+
+type ConflictResolutionPatchSet a = SimpleConflictResolution' (Set a)
+type instance ConflictResolution (PatchSet a) = ConflictResolutionPatchSet a
+
+instance Ord a => Semigroup (PatchSet a) where
+  p <> q = PatchSet { _rem = (q ^. rem) `Set.difference` (p ^. add) <> p ^. rem
+                    , _add = (q ^. add) `Set.difference` (p ^. rem) <> p ^. add
+                    } -- TODO Review
+
+instance Ord a => Monoid (PatchSet a) where
+  mempty = PatchSet mempty mempty
+
+instance Ord a => Group (PatchSet a) where
+  invert (PatchSet r a) = PatchSet a r
+
+instance Ord a => Composable (PatchSet a) where
+  composable _ _ = undefined
+
+instance Ord a => Action (PatchSet a) (Set a) where
+  act p source = (source `Set.difference` (p ^. rem)) <> p ^. add
+
+instance Applicable (PatchSet a) (Set a) where
+  applicable _ _ = mempty
+
+instance Ord a => Validity (PatchSet a) where
+  validate p = check (Set.disjoint (p ^. rem) (p ^. add)) "_rem and _add should be dijoint"
+
+instance Ord a => Transformable (PatchSet a) where
+  transformable = undefined
+
+  conflicts _p _q = undefined
+
+  transformWith conflict p q = undefined conflict p q
+
 instance ToSchema a => ToSchema (PatchSet a)
+-}
+
+type AddRem = Replace (Maybe ())
+
+remPatch, addPatch :: AddRem
+remPatch = replace (Just ()) Nothing
+addPatch = replace Nothing (Just ())
+
+isRem :: Replace (Maybe ()) -> Bool
+isRem = (== remPatch)
+
+type PatchMap = PM.PatchMap
+
+newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
+  deriving (Eq, Show, Generic, Validity, Semigroup, Monoid,
+            Transformable, Composable)
+
+type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
+type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
+
+-- TODO this breaks module abstraction
+makePrisms ''PM.PatchMap
+
+makePrisms ''PatchMSet
+
+_PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
+_PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
+  where
+    f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
+    f = Map.partition isRem >>> both %~ Map.keysSet
+
+    g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ()))
+    g (rems, adds) = Map.fromSet (const remPatch) rems
+                  <> Map.fromSet (const addPatch) adds
+
+instance Ord a => Action (PatchMSet a) (MSet a) where
+  act (PatchMSet p) (MSet m) = MSet $ act p m
+
+instance Ord a => Applicable (PatchMSet a) (MSet a) where
+  applicable (PatchMSet p) (MSet m) = applicable p m
+
+instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
+  toJSON     = toJSON . view _PatchMSetIso
+  toEncoding = toEncoding . view _PatchMSetIso
+
+instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
+  parseJSON = fmap (_PatchMSetIso #) . parseJSON
+
+instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
+  arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
+
+instance ToSchema a => ToSchema (PatchMSet a) where
+  -- TODO
+  declareNamedSchema _ = undefined
+
+type instance Patched (PatchMSet a) = MSet a
+
+instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
+  arbitrary = uncurry replace <$> arbitrary
+    -- If they happen to be equal then the patch is Keep.
 
 instance ToSchema a => ToSchema (Replace a) where
   declareNamedSchema (_ :: proxy (Replace a)) = do
@@ -199,29 +349,123 @@ instance ToSchema a => ToSchema (Replace a) where
       & required .~ [ "old", "new" ]
 
 data NgramsPatch =
-     NgramsPatch { _patch_children :: PatchSet NgramsTerm
+     NgramsPatch { _patch_children :: PatchMSet NgramsTerm
                  , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
                  }
-      deriving (Ord, Eq, Show, Generic)
+      deriving (Eq, Show, Generic)
+
 deriveJSON (unPrefix "_") ''NgramsPatch
 makeLenses ''NgramsPatch
 
--- instance Semigroup NgramsPatch where
-
 instance ToSchema  NgramsPatch
 
 instance Arbitrary NgramsPatch where
   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 
-newtype NgramsTablePatch =
-     NgramsTablePatch { _ntp_ngrams_patches :: Map NgramsTerm NgramsPatch }
-      deriving (Ord, Eq, Show, Generic, Arbitrary, ToJSON, FromJSON)
-makeLenses ''NgramsTablePatch
+type NgramsPatchIso = PairPatch (PatchMSet NgramsTerm) (Replace ListType)
+
+_NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
+_NgramsPatch = iso (\(NgramsPatch c l) -> c :*: l) (\(c :*: l) -> NgramsPatch c l)
+
+instance Semigroup NgramsPatch where
+  p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
+
+instance Monoid NgramsPatch where
+  mempty = _NgramsPatch # mempty
+
+instance Validity NgramsPatch where
+  validate p = p ^. _NgramsPatch . to validate
+
+instance Transformable NgramsPatch where
+  transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
+
+  conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
+
+  transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
+    where
+      (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
+
+type ConflictResolutionNgramsPatch =
+  ( ConflictResolutionPatchMSet NgramsTerm
+  , ConflictResolutionReplace ListType
+  )
+type instance ConflictResolution NgramsPatch =
+  ConflictResolutionNgramsPatch
+
+type PatchedNgramsPatch = (Set NgramsTerm, ListType)
+  -- ~ Patched NgramsPatchIso
+type instance Patched NgramsPatch = PatchedNgramsPatch
+
+instance Applicable NgramsPatch (Maybe NgramsElement) where
+  applicable p Nothing   = check (p == mempty) "NgramsPatch should be empty here"
+  applicable p (Just ne) =
+    -- TODO how to patch _ne_parent ?
+    applicable (p ^. patch_children) (ne ^. ne_children) <>
+    applicable (p ^. patch_list)     (ne ^. ne_list)
+
+instance Action NgramsPatch NgramsElement where
+  act p = (ne_children %~ act (p ^. patch_children))
+        . (ne_list     %~ act (p ^. patch_list))
+
+instance Action NgramsPatch (Maybe NgramsElement) where
+  act = fmap . act
+
+newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
+  deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
+
+instance FromField NgramsTablePatch
+  where
+    fromField = fromField'
+
+instance FromField (PatchMap NgramsType (PatchMap NodeId NgramsTablePatch))
+  where
+    fromField = fromField'
+
+--instance (Ord k, Action pv (Maybe v)) => Action (PatchMap k pv) (Map k v) where
+--
+type instance ConflictResolution NgramsTablePatch =
+  NgramsTerm -> ConflictResolutionNgramsPatch
+
+type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
+  -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
+type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
+
+makePrisms ''NgramsTablePatch
+instance ToSchema  (PatchMap NgramsTerm NgramsPatch)
 instance ToSchema  NgramsTablePatch
 
--- TODO: replace by mempty once we have the Monoid instance
-emptyNgramsTablePatch :: NgramsTablePatch
-emptyNgramsTablePatch = NgramsTablePatch mempty
+instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
+  applicable p = applicable (p ^. _NgramsTablePatch)
+
+instance Action NgramsTablePatch (Maybe NgramsTableMap) where
+  act p =
+    fmap (execState (reParentNgramsTablePatch p)) .
+    act (p ^. _NgramsTablePatch)
+
+instance Arbitrary NgramsTablePatch where
+  arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
+
+-- Should it be less than an Lens' to preserve PatchMap's abstraction.
+-- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
+-- ntp_ngrams_patches = _NgramsTablePatch .  undefined
+
+type ReParent a = forall m. MonadState NgramsTableMap m => a -> m ()
+
+reParent :: Maybe NgramsTerm -> ReParent NgramsTerm
+reParent parent child = at child . _Just . ne_parent .= parent
+
+reParentAddRem :: NgramsTerm -> NgramsTerm -> ReParent AddRem
+reParentAddRem parent child p =
+  reParent (if isRem p then Nothing else Just parent) child
+
+reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch
+reParentNgramsPatch parent ngramsPatch =
+  itraverse_ (reParentAddRem parent) (ngramsPatch ^. patch_children . _PatchMSet . _PatchMap)
+  -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
+
+reParentNgramsTablePatch :: ReParent NgramsTablePatch
+reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap)
+  -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
@@ -231,7 +475,7 @@ data Versioned a = Versioned
   { _v_version :: Version
   , _v_data    :: a
   }
-  deriving (Generic)
+  deriving (Generic, Show)
 deriveJSON (unPrefix "_v_") ''Versioned
 makeLenses ''Versioned
 instance ToSchema a => ToSchema (Versioned a)
@@ -262,14 +506,14 @@ ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ n
 
 type TableNgramsApiGet = Summary " Table Ngrams API Get"
                       :> QueryParam "ngramsType"   TabType
-                      :> QueryParam "list"   ListId
+                      :> QueryParams "list"   ListId
                       :> QueryParam "limit"  Limit
                       :> QueryParam "offset" Offset
                       :> Get    '[JSON] (Versioned NgramsTable)
 
 type TableNgramsApi = Summary " Table Ngrams API Change"
                       :> QueryParam "ngramsType"   TabType
-                      :> QueryParam "list"   ListId
+                      :> QueryParam' '[Required, Strict] "list" ListId
                       :> ReqBody '[JSON] (Versioned NgramsTablePatch)
                       :> Put     '[JSON] (Versioned NgramsTablePatch)
 
@@ -289,6 +533,7 @@ instance HasNgramError ServantErr where
 ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
 ngramError nne = throwError $ _NgramError # nne
 
+{-
 -- TODO: Replace.old is ignored which means that if the current list
 -- `GraphList` and that the patch is `Replace CandidateList StopList` then
 -- the list is going to be `StopList` while it should keep `GraphList`.
@@ -309,6 +554,7 @@ mkChildrenGroups addOrRem nt patches =
   | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
   , child <- patch ^.. patch_children . to addOrRem . folded
   ]
+-}
 
 ngramsTypeFromTabType :: Maybe TabType -> NgramsType
 ngramsTypeFromTabType maybeTabType =
@@ -322,46 +568,201 @@ ngramsTypeFromTabType maybeTabType =
               Terms      -> Ngrams.NgramsTerms
               _          -> panic $ lieu <> "No Ngrams for this tab"
 
+------------------------------------------------------------------------
+data Repo s p = Repo
+  { _r_version :: Version
+  , _r_state   :: s
+  , _r_history :: [p]
+    -- ^ first patch in the list is the most recent
+  }
+  deriving (Generic)
+
+instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
+  parseJSON = genericParseJSON $ unPrefix "_r_"
+
+instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
+  toJSON     = genericToJSON     $ unPrefix "_r_"
+  toEncoding = genericToEncoding $ unPrefix "_r_"
+
+makeLenses ''Repo
+
+initRepo :: Monoid s => Repo s p
+initRepo = Repo 1 mempty []
+
+type NgramsRepo       = Repo NgramsState NgramsStatePatch
+type NgramsState      = Map NgramsType (Map NodeId NgramsTableMap)
+type NgramsStatePatch = PatchMap NgramsType (PatchMap NodeId NgramsTablePatch)
+
+initMockRepo :: NgramsRepo
+initMockRepo = Repo 1 s []
+  where
+    s = Map.singleton Ngrams.NgramsTerms
+      $ Map.singleton 47254
+      $ Map.fromList
+      [ (n ^. ne_ngrams, n) | n <- mockTable ^. _NgramsTable ]
+
+class HasRepoVar env where
+  repoVar :: Getter env (MVar NgramsRepo)
+
+instance HasRepoVar (MVar NgramsRepo) where
+  repoVar = identity
+
+class HasRepoSaver env where
+  repoSaver :: Getter env (IO ())
+
+instance HasRepoSaver (IO ()) where
+  repoSaver = identity
+
+type RepoCmdM env err m =
+  ( MonadReader env m
+  , MonadError err m
+  , MonadIO m
+  , HasRepoVar env
+  , HasRepoSaver env
+  )
+------------------------------------------------------------------------
+
+saveRepo :: ( MonadReader env m, MonadIO m, HasRepoSaver env )
+         => m ()
+saveRepo = liftIO =<< view repoSaver
+
+listTypeConflictResolution :: ListType -> ListType -> ListType
+listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
+
+ngramsStatePatchConflictResolution
+  :: NgramsType -> NodeId -> NgramsTerm
+  -> ConflictResolutionNgramsPatch
+ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
+  = (const ours, ours)
+  -- undefined {- TODO think this through -}, listTypeConflictResolution)
+
+class HasInvalidError e where
+  _InvalidError :: Prism' e Validation
+
+instance HasInvalidError ServantErr where
+  _InvalidError = panic "error" {-prism' make match
+    where
+      err = err500 { errBody = "InvalidError" }
+      make _ = err
+      match e = guard (e == err) $> UnsupportedVersion-}
+
+assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
+assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
+
+-- Current state:
+--   Insertions are not considered as patches,
+--   they do not extend history,
+--   they do not bump version.
+insertNewOnly :: a -> Maybe a -> Maybe a
+insertNewOnly a = maybe (Just a) (const $ error "insertNewOnly: impossible")
+  -- TODO error handling
+
+something :: Monoid a => Maybe a -> a
+something Nothing  = mempty
+something (Just a) = a
+
+putListNgrams :: RepoCmdM env err m
+              => NodeId -> NgramsType
+              -> [NgramsElement] -> m ()
+putListNgrams listId ngramsType nes = do
+  var <- view repoVar
+  liftIO $ modifyMVar_ var $
+    pure . (r_state . at ngramsType %~ (Just . (at listId %~ insertNewOnly m) . something))
+  saveRepo
+  where
+    m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
 
 -- Apply the given patch to the DB and returns the patch to be applied on the
--- cilent.
+-- client.
 -- TODO:
 -- In this perliminary version the OT aspect is missing, therefore the version
 -- number is always 1 and the returned patch is always empty.
-tableNgramsPatch :: (HasNgramError err, HasNodeError err)
-                 => CorpusId -> Maybe TabType -> Maybe ListId
+tableNgramsPatch :: (HasNgramError err, HasInvalidError err,
+                     RepoCmdM env err m)
+                 => CorpusId -> Maybe TabType -> ListId
                  -> Versioned NgramsTablePatch
-                 -> Cmd err (Versioned NgramsTablePatch)
-tableNgramsPatch corpusId maybeTabType maybeList (Versioned version patch) = do
+                 -> m (Versioned NgramsTablePatch)
+tableNgramsPatch _corpusId maybeTabType listId (Versioned p_version p_table) = do
+  let ngramsType        = ngramsTypeFromTabType maybeTabType
+      (p0, p0_validity) = PM.singleton listId p_table
+      (p, p_validity)   = PM.singleton ngramsType p0
+
+  assertValid p0_validity
+  assertValid p_validity
+
+  var <- view repoVar
+  (p'_applicable, vq') <- liftIO $ modifyMVar var $ \r ->
+    let
+      q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
+      (p', q') = transformWith ngramsStatePatchConflictResolution p q
+      r' = r & r_version +~ 1
+             & r_state   %~ act p'
+             & r_history %~ (p' :)
+      q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
+      p'_applicable = applicable p' (r ^. r_state)
+    in
+    pure (r', (p'_applicable, Versioned (r' ^. r_version) q'_table))
+
+  saveRepo
+  assertValid p'_applicable
+  pure vq'
+
+  {- DB version
   when (version /= 1) $ ngramError UnsupportedVersion
-  let ngramsType = ngramsTypeFromTabType maybeTabType
-  listId <- maybe (defaultList corpusId) pure maybeList
   updateNodeNgrams $ NodeNgramsUpdate
     { _nnu_user_list_id = listId
     , _nnu_lists_update = mkListsUpdate ngramsType patch
     , _nnu_rem_children = mkChildrenGroups _rem ngramsType patch
     , _nnu_add_children = mkChildrenGroups _add ngramsType patch
     }
-  pure $ Versioned 1 emptyNgramsTablePatch
+  pure $ Versioned 1 mempty
+  -}
+
+mergeNgramsElement :: NgramsElement -> NgramsElement -> NgramsElement
+mergeNgramsElement _neOld neNew = neNew
+  {-
+  { _ne_list        :: ListType
+  If we merge the parents/children we can potentially create cycles!
+  , _ne_parent      :: Maybe NgramsTerm
+  , _ne_children    :: MSet NgramsTerm
+  }
+  -}
+
+getListNgrams :: RepoCmdM env err m
+                => [NodeId] -> NgramsType -> m (Versioned ListNgrams)
+getListNgrams nodeIds ngramsType = do
+  v <- view repoVar
+  repo <- liftIO $ readMVar v
+
+  let
+    ngramsMap = repo ^. r_state . at ngramsType . _Just
+
+    ngrams =
+      Map.unionsWith mergeNgramsElement
+        [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
+
+  pure $ Versioned (repo ^. r_version) (NgramsTable (ngrams ^.. each))
+
 
 -- | TODO Errors management
 --  TODO: polymorphic for Annuaire or Corpus or ...
-getTableNgrams :: HasNodeError err
+-- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
+getTableNgrams :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
                => CorpusId -> Maybe TabType
-               -> Maybe ListId -> Maybe Limit -> Maybe Offset
-               -> Cmd err (Versioned NgramsTable)
-getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
+               -> [ListId] -> Maybe Limit -> Maybe Offset
+               -- -> Maybe MinSize -> Maybe MaxSize
+               -- -> Maybe ListType
+               -- -> Maybe Text -- full text search
+               -> m (Versioned NgramsTable)
+getTableNgrams _cId maybeTabType listIds mlimit moffset = do
   let ngramsType = ngramsTypeFromTabType maybeTabType
-  listId <- maybe (defaultList cId) pure maybeListId
 
   let
     defaultLimit = 10 -- TODO
     limit_  = maybe defaultLimit identity mlimit
     offset_ = maybe 0 identity moffset
+  
+  lists <- catMaybes <$> listsWith userMaster
+  trace (show lists) $ getListNgrams (lists <> listIds) ngramsType
+    & mapped . v_data . _NgramsTable %~ (take limit_ . drop offset_)
 
-  ngramsTableDatas <-
-    Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
-
-  -- printDebug "ngramsTableDatas" ngramsTableDatas
-
-  pure $ Versioned 1 $ NgramsTable (toNgramsElement ngramsTableDatas)

src/Gargantext/API/Node.hs

@@ -46,7 +46,7 @@ import Data.Time (UTCTime)
 import GHC.Generics (Generic)
 import Servant
 
-import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams)
+import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams, HasRepoVar, HasRepoSaver)
 import Gargantext.Prelude
 import Gargantext.Database.Types.Node
 import Gargantext.Database.Utils -- (Cmd, CmdM)
@@ -72,7 +72,10 @@ import Gargantext.Database.Types.Node (CorpusId, ContactId)
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
-type GargServer api = forall env m. CmdM env ServantErr m => ServerT api m
+type GargServer api =
+  forall env m.
+    (CmdM env ServantErr m, HasRepoVar env, HasRepoSaver env)
+    => ServerT api m
 
 -------------------------------------------------------------------
 -- TODO-ACCESS: access by admin only.
@@ -279,7 +282,7 @@ graphAPI nId = do
 
   nodeGraph <- getNode nId HyperdataGraph
 
-  let title = "Graph Title"
+  let title = "Title"
   let metadata = GraphMetadata title [maybe 0 identity $ _node_parentId nodeGraph]
                                      [ LegendField 1 "#FFF" "Cluster"
                                      , LegendField 2 "#FFF" "Cluster"

src/Gargantext/API/Settings.hs

@@ -17,25 +17,31 @@ Portability : POSIX
 {-# LANGUAGE ScopedTypeVariables         #-}
 {-# LANGUAGE TemplateHaskell             #-}
 {-# LANGUAGE OverloadedStrings           #-}
+{-# LANGUAGE FlexibleContexts            #-}
 {-# LANGUAGE FlexibleInstances           #-}
+{-# LANGUAGE RankNTypes                  #-}
 
 module Gargantext.API.Settings
     where
 
+import System.Directory
 import System.Log.FastLogger
 import GHC.Enum
 import GHC.Generics (Generic)
-import Prelude (Bounded())
+import Prelude (Bounded(), fail)
 import System.Environment (lookupEnv)
 import System.IO (FilePath)
 import Database.PostgreSQL.Simple (Connection, connect)
 import Network.HTTP.Client (Manager)
 import Network.HTTP.Client.TLS (newTlsManager)
 
+import Data.Aeson
 import Data.Maybe (fromMaybe)
 import Data.Either (either)
+import Data.JsonState (mkSaveState)
 import Data.Text
 import Data.Text.Encoding (encodeUtf8)
+import Data.Time.Units
 import Data.ByteString.Lazy.Internal
 
 import Servant
@@ -45,10 +51,14 @@ import Web.HttpApiData (parseUrlPiece)
 import qualified Jose.Jwk as Jose
 import qualified Jose.Jwa as Jose
 
+import Control.Concurrent
+import Control.Exception (finally)
 import Control.Monad.Logger
+import Control.Monad.Reader
 import Control.Lens
 import Gargantext.Prelude
-import Gargantext.Database.Utils (databaseParameters, HasConnection(..))
+import Gargantext.Database.Utils (databaseParameters, HasConnection(..), Cmd', runCmd)
+import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), initMockRepo, r_version, saveRepo)
 import Gargantext.API.Orchestrator.Types
 
 type PortNumber = Int
@@ -125,12 +135,14 @@ optSetting name d = do
 data FireWall = FireWall { unFireWall :: Bool }
 
 data Env = Env
-  { _env_settings :: !Settings
-  , _env_logger   :: !LoggerSet
-  , _env_conn     :: !Connection
-  , _env_manager  :: !Manager
-  , _env_self_url :: !BaseUrl
-  , _env_scrapers :: !ScrapersEnv
+  { _env_settings   :: !Settings
+  , _env_logger     :: !LoggerSet
+  , _env_conn       :: !Connection
+  , _env_repo_var   :: !(MVar NgramsRepo)
+  , _env_repo_saver :: !(IO ())
+  , _env_manager    :: !Manager
+  , _env_self_url   :: !BaseUrl
+  , _env_scrapers   :: !ScrapersEnv
   }
   deriving (Generic)
 
@@ -139,6 +151,12 @@ makeLenses ''Env
 instance HasConnection Env where
   connection = env_conn
 
+instance HasRepoVar Env where
+  repoVar = env_repo_var
+
+instance HasRepoSaver Env where
+  repoSaver = env_repo_saver
+
 data MockEnv = MockEnv
   { _menv_firewall :: !FireWall
   }
@@ -146,22 +164,109 @@ data MockEnv = MockEnv
 
 makeLenses ''MockEnv
 
+repoSnapshot :: FilePath
+repoSnapshot = "repo.json"
+
+readRepo :: IO (MVar NgramsRepo)
+readRepo = do
+  -- | Does file exist ? :: Bool
+  repoFile <- doesFileExist repoSnapshot
+  
+  -- | Is file not empty ? :: Bool
+  repoExists <- if repoFile
+             then (>0) <$> getFileSize repoSnapshot
+             else pure repoFile
+  
+  newMVar =<<
+    if repoExists
+      then do
+        e_repo <- eitherDecodeFileStrict repoSnapshot
+        repo   <- either fail pure e_repo
+        let archive = repoSnapshot <> ".v" <> show (repo ^. r_version)
+        copyFile repoSnapshot archive
+        pure repo
+      else
+        pure initMockRepo
+
+mkRepoSaver :: MVar NgramsRepo -> IO (IO ())
+mkRepoSaver repo_var = do
+  saveAction <- mkSaveState (10 :: Second) repoSnapshot
+  pure $ readMVar repo_var >>= saveAction
+
 newEnv :: PortNumber -> FilePath -> IO Env
 newEnv port file = do
   manager <- newTlsManager
   settings <- pure (devSettings & appPort .~ port) -- TODO read from 'file'
   when (port /= settings ^. appPort) $
     panic "TODO: conflicting settings of port"
+  
   self_url <- parseBaseUrl $ "http://0.0.0.0:" <> show port
-  param <- databaseParameters file
-  conn <- connect param
+  param    <- databaseParameters file
+  conn     <- connect param
+  
+  repo_var     <- readRepo
+  repo_saver   <- mkRepoSaver repo_var
   scrapers_env <- newJobEnv defaultSettings manager
   logger <- newStderrLoggerSet defaultBufSize
+  
   pure $ Env
-    { _env_settings = settings
-    , _env_logger   = logger
-    , _env_conn     = conn
-    , _env_manager  = manager
-    , _env_scrapers = scrapers_env
-    , _env_self_url = self_url
+    { _env_settings   = settings
+    , _env_logger     = logger
+    , _env_conn       = conn
+    , _env_repo_var   = repo_var
+    , _env_repo_saver = repo_saver
+    , _env_manager    = manager
+    , _env_scrapers   = scrapers_env
+    , _env_self_url   = self_url
     }
+
+data DevEnv = DevEnv
+  { _dev_env_conn       :: !Connection
+  , _dev_env_repo_var   :: !(MVar NgramsRepo)
+  , _dev_env_repo_saver :: !(IO ())
+  }
+
+makeLenses ''DevEnv
+
+instance HasConnection DevEnv where
+  connection = dev_env_conn
+
+instance HasRepoVar DevEnv where
+  repoVar = dev_env_repo_var
+
+instance HasRepoSaver DevEnv where
+  repoSaver = dev_env_repo_saver
+
+newDevEnvWith :: FilePath -> IO DevEnv
+newDevEnvWith file = do
+  param      <- databaseParameters file
+  conn       <- connect param
+  repo_var   <- newMVar initMockRepo
+  repo_saver <- mkRepoSaver repo_var
+  pure $ DevEnv
+    { _dev_env_conn       = conn
+    , _dev_env_repo_var   = repo_var
+    , _dev_env_repo_saver = repo_saver
+    }
+
+newDevEnv :: IO DevEnv
+newDevEnv = newDevEnvWith "gargantext.ini"
+
+-- Use only for dev
+-- In particular this writes the repo file after running
+-- the command.
+-- This function is constrained to the DevEnv rather than
+-- using HasConnection and HasRepoVar.
+runCmdDev :: Show err => DevEnv -> Cmd' DevEnv err a -> IO a
+runCmdDev env f =
+  (either (fail . show) pure =<< runCmd env f)
+    `finally`
+  runReaderT saveRepo env
+
+-- Use only for dev
+runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
+runCmdDevNoErr = runCmdDev
+
+-- Use only for dev
+runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServantErr a -> IO a
+runCmdDevServantErr = runCmdDev

src/Gargantext/Database/Cooc.hs

@@ -20,14 +20,15 @@ module Gargantext.Database.Cooc where
 import Database.PostgreSQL.Simple.SqlQQ
 
 import Gargantext.Prelude
-import Gargantext.Database.Utils (Cmd, runCmdDevNoErr, runPGSQuery)
+import Gargantext.Database.Utils (Cmd, runPGSQuery)
+import Gargantext.API.Settings (runCmdDevNoErr, DevEnv)
 
 type CorpusId    = Int
 type MainListId  = Int
 type GroupListId = Int
 
-coocTest :: IO [(Int, Int, Int)]
-coocTest = runCmdDevNoErr $ dBcooc 421968 446602 446599
+coocTest :: DevEnv -> IO [(Int, Int, Int)]
+coocTest env = runCmdDevNoErr env $ dBcooc 421968 446602 446599
 
 dBcooc :: CorpusId -> MainListId -> GroupListId -> Cmd err [(Int, Int, Int)]
 dBcooc corpus mainList groupList = runPGSQuery [sql|

src/Gargantext/Database/Flow.hs

@@ -9,20 +9,25 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE FlexibleContexts  #-}
 
 module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
     where
 
+--import Debug.Trace (trace)
 --import Control.Lens (view)
+import Control.Monad (mapM_)
 import Control.Monad.IO.Class (liftIO)
 --import Gargantext.Core.Types
 --import Gargantext.Database.Node.Contact (HyperdataContact(..))
-import Data.Map (Map, lookup)
+import Data.Map (Map, lookup, fromListWith, toList)
 import Data.Maybe (Maybe(..), catMaybes)
+import Data.Monoid
 import Data.Text (Text, splitOn, intercalate)
 import Data.Tuple.Extra (both)
 import Data.List (concat)
@@ -45,18 +50,31 @@ import Gargantext.Database.Schema.NodeNgram (NodeNgramPoly(..), insertNodeNgrams
 import Gargantext.Database.Schema.NodeNgramsNgrams (NodeNgramsNgramsPoly(..), insertNodeNgramsNgramsNew)
 import Gargantext.Database.Schema.User (getUser, UserLight(..))
 import Gargantext.Database.Types.Node (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
-import Gargantext.Database.Utils (Cmd)
+import Gargantext.Database.Utils (Cmd, CmdM)
 import Gargantext.Text.Terms (TermType(..))
 import Gargantext.Ext.IMT (toSchoolName)
 import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
 import Gargantext.Prelude
 import Gargantext.Text.Parsers (parseDocs, FileFormat)
 import System.FilePath (FilePath)
+import Gargantext.API.Ngrams (HasRepoVar)
+import Servant (ServantErr)
+import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams, RepoCmdM)
+--import Gargantext.Database.Schema.User (insertUsers, simpleUser, gargantuaUser)
 import qualified Data.Map as DM
 
+type FlowCmdM env err m =
+  ( CmdM     env err m
+  , RepoCmdM env err m
+  , HasNodeError err
+  , HasRepoVar env
+  )
 
-flowCorpus :: HasNodeError err => FileFormat -> FilePath -> CorpusName -> Cmd err CorpusId
+
+flowCorpus :: FlowCmdM env ServantErr m
+           => FileFormat -> FilePath -> CorpusName -> m CorpusId
 flowCorpus ff fp cName = do
+  --insertUsers [gargantuaUser, simpleUser]
   hyperdataDocuments' <- map addUniqIdsDoc <$> liftIO (parseDocs ff fp)
   params <- flowInsert NodeCorpus hyperdataDocuments' cName
   flowCorpus' NodeCorpus hyperdataDocuments' params
@@ -76,27 +94,6 @@ flowInsert _nt hyperdataDocuments cName = do
   pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
 
 
-flowAnnuaire :: HasNodeError err => FilePath -> Cmd err ()
-flowAnnuaire filePath = do
-  contacts <- liftIO $ deserialiseImtUsersFromFile filePath
-  ps <- flowInsertAnnuaire "Annuaire" $ map (\h-> ToDbContact h) $ map addUniqIdsContact contacts
-  printDebug "length annuaire" ps
-
-
-flowInsertAnnuaire :: HasNodeError err => CorpusName -> [ToDbData]
-                    -> Cmd err ([ReturnId], UserId, CorpusId, UserId, CorpusId)
-flowInsertAnnuaire name children = do
-
-  (masterUserId, _, masterCorpusId) <- subFlowCorpus userMaster corpusMasterName
-  ids  <- insertDocuments masterUserId masterCorpusId NodeContact children
-
-  (userId, _, userCorpusId) <- subFlowAnnuaire userArbitrary name
-  _ <- add userCorpusId (map reId ids)
-
- --printDebug "AnnuaireID" userCorpusId
-
-  pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
-
 -- TODO-ACCESS:
 --   check userId       CanFillUserCorpus   userCorpusId
 --   check masterUserId CanFillMasterCorpus masterCorpusId
@@ -104,31 +101,28 @@ flowInsertAnnuaire name children = do
 -- TODO-EVENTS:
 --   InsertedNgrams ?
 --   InsertedNodeNgrams ?
-flowCorpus' :: HasNodeError err
+flowCorpus' :: FlowCmdM env err m
             => NodeType -> [HyperdataDocument]
             -> ([ReturnId], UserId, CorpusId, UserId, CorpusId)
-            -> Cmd err CorpusId
-flowCorpus' NodeCorpus hyperdataDocuments (ids,_masterUserId,_masterCorpusId, userId,userCorpusId) = do
+            -> m CorpusId
+flowCorpus' NodeCorpus hyperdataDocuments (ids,masterUserId,masterCorpusId, userId,userCorpusId) = do
 --------------------------------------------------
-  -- List Ngrams Flow
-  _userListId <- flowListUser userId userCorpusId 500
-  --printDebug "Working on User ListId : " userListId
 
   let documentsWithId = mergeData (toInserted ids) (toInsert hyperdataDocuments)
-  -- printDebug "documentsWithId" documentsWithId
+  --printDebug "documentsWithId" documentsWithId
   docsWithNgrams <- documentIdWithNgrams extractNgramsT documentsWithId
-  -- printDebug "docsWithNgrams" docsWithNgrams
+  --printDebug "docsWithNgrams" docsWithNgrams
   let maps            = mapNodeIdNgrams docsWithNgrams
 
-  -- printDebug "maps" (maps)
+  --printDebug "maps" (maps)
   terms2id <- insertNgrams $ DM.keys maps
   let indexedNgrams = DM.mapKeys (indexNgrams terms2id) maps
-  -- printDebug "inserted ngrams" indexedNgrams
+  --printDebug "inserted ngrams" indexedNgrams
   _             <- insertToNodeNgrams indexedNgrams
 
-  --listId2    <- flowList masterUserId masterCorpusId indexedNgrams
-  --printDebug "Working on ListId : " listId2
-  --}
+  -- List Ngrams Flow
+  _masterListId <- flowList masterUserId masterCorpusId indexedNgrams
+  _userListId   <- flowListUser userId userCorpusId 500
 --------------------------------------------------
   _ <- mkDashboard userCorpusId userId
   _ <- mkGraph     userCorpusId userId
@@ -148,19 +142,22 @@ type CorpusName = Text
 subFlowCorpus :: HasNodeError err => Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
 subFlowCorpus username cName = do
   maybeUserId <- getUser username
-
   userId <- case maybeUserId of
         Nothing   -> nodeError NoUserFound
         -- mk NodeUser gargantua_id "Node Gargantua"
         Just user -> pure $ userLight_id user
 
+  --printDebug "userId" userId
   rootId' <- map _node_id <$> getRoot username
 
+  --printDebug "rootId'" rootId'
   rootId'' <- case rootId' of
         []  -> mkRoot username userId
         n   -> case length n >= 2 of
             True  -> nodeError ManyNodeUsers
             False -> pure rootId'
+
+  --printDebug "rootId''" rootId''
   rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
 
   corpusId'' <- if username == userMaster
@@ -181,32 +178,6 @@ subFlowCorpus username cName = do
   pure (userId, rootId, corpusId)
 
 
-subFlowAnnuaire :: HasNodeError err => Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
-subFlowAnnuaire username _cName = do
-  maybeUserId <- getUser username
-
-  userId <- case maybeUserId of
-        Nothing   -> nodeError NoUserFound
-        -- mk NodeUser gargantua_id "Node Gargantua"
-        Just user -> pure $ userLight_id user
-
-  rootId' <- map _node_id <$> getRoot username
-
-  rootId'' <- case rootId' of
-        []  -> mkRoot username userId
-        n   -> case length n >= 2 of
-            True  -> nodeError ManyNodeUsers
-            False -> pure rootId'
-  rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
-
-  corpusId' <- mkAnnuaire rootId userId
-
-  corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
-
-  --printDebug "(username, userId, rootId, corpusId)"
-  --            (username, userId, rootId, corpusId)
-  pure (userId, rootId, corpusId)
-
 ------------------------------------------------------------------------
 toInsert :: [HyperdataDocument] -> Map HashId HyperdataDocument
 toInsert = DM.fromList . map (\d -> (maybe err identity (_hyperdataDocument_uniqId d), d))
@@ -271,11 +242,13 @@ mapNodeIdNgrams = DM.unionsWith (DM.unionWith (DM.unionWith (+))) . fmap f
         nId = documentId $ documentWithId d
 
 ------------------------------------------------------------------------
-flowList :: HasNodeError err => UserId -> CorpusId
-         -> Map NgramsIndexed (Map NgramsType (Map NodeId Int)) -> Cmd err ListId
-flowList uId cId _ngs = do
-  -- printDebug "ngs:" ngs
+flowList :: FlowCmdM env err m => UserId -> CorpusId
+         -> Map NgramsIndexed (Map NgramsType (Map NodeId Int))
+         -> m ListId
+flowList uId cId ngs = do
+  --printDebug "ngs:" ngs
   lId <- getOrMkList cId uId
+  printDebug "listId flowList" lId
   --printDebug "ngs" (DM.keys ngs)
   -- TODO add stemming equivalence of 2 ngrams
   -- TODO needs rework
@@ -283,18 +256,21 @@ flowList uId cId _ngs = do
   -- _ <- insertGroups lId groupEd
 
 -- compute Candidate / Map
-  --is <- insertLists lId $ ngrams2list ngs
-  --printDebug "listNgrams inserted :" is
+  mapM_ (\(typeList, ngElmts) -> putListNgrams lId typeList ngElmts) $ toList $ ngrams2list' ngs
 
   pure lId
 
-flowListUser :: HasNodeError err => UserId -> CorpusId -> Int -> Cmd err NodeId
+flowListUser :: FlowCmdM env err m
+             => UserId -> CorpusId -> Int -> m ListId
 flowListUser uId cId n = do
   lId <- getOrMkList cId uId
-  -- is <- insertLists lId $ ngrams2list ngs
 
-  ngs <- take n <$> sortWith tficf_score <$> getTficf userMaster cId lId NgramsTerms
-  _ <- insertNodeNgrams [ NodeNgram lId (tficf_ngramsId ng) Nothing (ngramsTypeId NgramsTerms) (fromIntegral $ listTypeId GraphList) 1 | ng <- ngs]
+  ngs <- take n <$> sortWith tficf_score
+                <$> getTficf userMaster cId lId NgramsTerms
+
+  putListNgrams lId NgramsTerms $
+    [ NgramsElement (tficf_ngramsTerms ng) GraphList 1 Nothing mempty
+    | ng <- ngs ]
 
   pure lId
 
@@ -321,13 +297,25 @@ insertGroups lId ngrs =
 
 ------------------------------------------------------------------------
 ngrams2list :: Map NgramsIndexed (Map NgramsType a)
-            -> [(ListType, (NgramsType,NgramsIndexed))]
+            -> [(ListType, (NgramsType, NgramsIndexed))]
 ngrams2list m =
   [ (CandidateList, (t, ng))
   | (ng, tm) <- DM.toList m
   , t <- DM.keys tm
   ]
 
+ngrams2list' :: Map NgramsIndexed (Map NgramsType a)
+            -> Map NgramsType [NgramsElement]
+ngrams2list' m = fromListWith (<>)
+  [ (t, [NgramsElement (_ngramsTerms $ _ngrams ng) CandidateList 1 Nothing mempty])
+  | (ng, tm) <- DM.toList m
+  , t <- DM.keys tm
+  ]
+
+
+
+
+
 -- | TODO: weight of the list could be a probability
 insertLists :: HasNodeError err => ListId -> [(ListType, (NgramsType, NgramsIndexed))] -> Cmd err Int
 insertLists lId lngs = insertNodeNgrams [ NodeNgram lId (_ngramsId ng) Nothing (ngramsTypeId ngt) (fromIntegral $ listTypeId l) 1
@@ -335,3 +323,56 @@ insertLists lId lngs = insertNodeNgrams [ NodeNgram lId (_ngramsId ng) Nothing (
                    ]
 ------------------------------------------------------------------------
 
+
+-- | Annuaire
+
+flowAnnuaire :: FlowCmdM env ServantErr m => FilePath -> m ()
+flowAnnuaire filePath = do
+  contacts <- liftIO $ deserialiseImtUsersFromFile filePath
+  ps <- flowInsertAnnuaire "Annuaire" $ map (\h-> ToDbContact h) $ map addUniqIdsContact contacts
+  printDebug "length annuaire" ps
+
+
+flowInsertAnnuaire :: HasNodeError err => CorpusName -> [ToDbData]
+                    -> Cmd err ([ReturnId], UserId, CorpusId, UserId, CorpusId)
+flowInsertAnnuaire name children = do
+
+  (masterUserId, _, masterCorpusId) <- subFlowCorpus userMaster corpusMasterName
+  ids  <- insertDocuments masterUserId masterCorpusId NodeContact children
+
+  (userId, _, userCorpusId) <- subFlowAnnuaire userArbitrary name
+  _ <- add userCorpusId (map reId ids)
+
+  printDebug "AnnuaireID" userCorpusId
+
+  pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
+
+
+subFlowAnnuaire :: HasNodeError err =>
+  Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
+subFlowAnnuaire username _cName = do
+  maybeUserId <- getUser username
+
+  userId <- case maybeUserId of
+        Nothing   -> nodeError NoUserFound
+        -- mk NodeUser gargantua_id "Node Gargantua"
+        Just user -> pure $ userLight_id user
+
+  rootId' <- map _node_id <$> getRoot username
+
+  rootId'' <- case rootId' of
+        []  -> mkRoot username userId
+        n   -> case length n >= 2 of
+            True  -> nodeError ManyNodeUsers
+            False -> pure rootId'
+  rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
+
+  corpusId' <- mkAnnuaire rootId userId
+
+  corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
+
+  printDebug "(username, userId, rootId, corpusId)"
+              (username, userId, rootId, corpusId)
+  pure (userId, rootId, corpusId)
+
+

src/Gargantext/Database/Lists.hs

+{-|
+Module      : Gargantext.Database.Lists
+Description : Main requests of Node to the database
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-orphans        #-}
+
+{-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE DeriveGeneric          #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE NoImplicitPrelude      #-}
+{-# LANGUAGE RankNTypes             #-}
+{-# LANGUAGE TemplateHaskell        #-}
+
+module Gargantext.Database.Lists where
+
+import Control.Arrow (returnA)
+import Gargantext.Core.Types -- (NodePoly(..), NodeCorpus, ListId)
+import Gargantext.Core.Types.Individu (Username)
+import Gargantext.Database.Config (nodeTypeId)
+import Gargantext.Database.Schema.Node -- (HasNodeError, queryNodeTable)
+import Gargantext.Database.Schema.User -- (queryUserTable)
+import Gargantext.Database.Utils
+import Gargantext.Prelude hiding (sum, head)
+import Opaleye hiding (FromField)
+import Opaleye.Internal.QueryArr (Query)
+import Prelude hiding (null, id, map, sum)
+
+-- | To get all lists of a user
+-- /!\ lists of different types of corpora (Annuaire or Documents)
+listsWith :: HasNodeError err => Username -> Cmd err [Maybe ListId]
+listsWith u = runOpaQuery (selectLists u)
+  where
+    selectLists u = proc () -> do
+      (auth_user,nodes) <- listsWithJoin2 -< ()
+      restrict -< user_username auth_user .== (pgStrictText u)
+      restrict -< _node_typename nodes .== (toNullable $ pgInt4 $ nodeTypeId NodeList)
+      returnA  -< _node_id nodes
+
+listsWithJoin2 :: Query (UserRead, NodeReadNull)
+listsWithJoin2 = leftJoin queryUserTable queryNodeTable cond12
+  where
+    cond12 (u,n)       = user_id u   .== _node_userId n
+
+{-
+listsWithJoin3 :: Query (NodeRead, (UserRead, NodeReadNull))
+listsWithJoin3 = leftJoin3 queryUserTable queryNodeTable queryNodeTable cond12 cond23
+  where
+    cond12 :: (NodeRead
+    cond12 (u,n)       = user_id u   .== _node_userId n
+    cond23 :: (NodeRead, (UserRead, NodeReadNull)) -> Column PGBool
+    cond23 (n1,(u,n2)) = (toNullable $ _node_id n1) .== _node_parentId n2
+--}
+

src/Gargantext/Database/Metrics/TFICF.hs

@@ -143,4 +143,3 @@ GROUP BY nu.id,nu.terms
   |]
 
 
-

src/Gargantext/Database/Schema/Ngrams.hs

@@ -25,8 +25,10 @@ Ngrams connection to the Database.
 
 module Gargantext.Database.Schema.Ngrams where
 
+import Data.Aeson (FromJSON, FromJSONKey)
 import Control.Lens (makeLenses, view, over)
 import Control.Monad (mzero)
+import Data.Aeson
 import Data.ByteString.Internal (ByteString)
 import Data.Map (Map, fromList, lookup, fromListWith)
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
@@ -58,13 +60,11 @@ type NgramsTerms = Text
 type NgramsId    = Int
 type Size        = Int
 
---{-
 data NgramsPoly id terms n = NgramsDb { ngrams_id    :: id
-                                    , ngrams_terms :: terms
-                                    , ngrams_n     :: n
-                                    } deriving (Show)
+                                      , ngrams_terms :: terms
+                                      , ngrams_n     :: n
+                                      } deriving (Show)
 
---}
 type NgramsWrite = NgramsPoly (Maybe (Column PGInt4))
                                    (Column PGText)
                                    (Column PGInt4)
@@ -77,7 +77,6 @@ type NgramsReadNull = NgramsPoly (Column (Nullable PGInt4))
                                  (Column (Nullable PGText))
                                  (Column (Nullable PGInt4))
 
---{-
 type NgramsDb = NgramsPoly Int Text Int
 
 $(makeAdaptorAndInstance "pNgramsDb"    ''NgramsPoly)
@@ -85,17 +84,16 @@ $(makeAdaptorAndInstance "pNgramsDb"    ''NgramsPoly)
 
 ngramsTable :: Table NgramsWrite NgramsRead
 ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { ngrams_id    = optional "id"
-                                            , ngrams_terms = required "terms"
-                                            , ngrams_n     = required "n"
-                                            }
-                                )
---{-
+                                                 , ngrams_terms = required "terms"
+                                                 , ngrams_n     = required "n"
+                                                 }
+                              )
+
 queryNgramsTable :: Query NgramsRead
 queryNgramsTable = queryTable ngramsTable
 
 dbGetNgramsDb :: Cmd err [NgramsDb]
 dbGetNgramsDb = runOpaQuery queryNgramsTable
---}
 
 -- | Main Ngrams Types
 -- | Typed Ngrams
@@ -104,7 +102,12 @@ dbGetNgramsDb = runOpaQuery queryNgramsTable
 -- ngrams in authors field of document has Authors Type
 -- ngrams in text (title or abstract) of documents has Terms Type
 data NgramsType = Authors | Institutes | Sources | NgramsTerms
-  deriving (Eq, Show, Ord, Enum, Bounded)
+  deriving (Eq, Show, Ord, Enum, Bounded, Generic)
+
+instance FromJSON NgramsType
+instance FromJSONKey NgramsType
+instance ToJSON NgramsType
+instance ToJSONKey NgramsType
 
 newtype NgramsTypeId = NgramsTypeId Int
   deriving (Eq, Show, Ord, Num)

src/Gargantext/Database/Schema/Node.hs

@@ -155,32 +155,33 @@ instance QueryRunnerColumnDefault PGInt4 NodeId
 ------------------------------------------------------------------------
 $(makeAdaptorAndInstance "pNode" ''NodePoly)
 $(makeLensesWith abbreviatedFields ''NodePoly)
+
 $(makeAdaptorAndInstance "pNodeSearch" ''NodePolySearch)
 $(makeLensesWith abbreviatedFields ''NodePolySearch)
 
-type NodeWrite = NodePoly  (Maybe (Column  PGInt4       ))
-                                  (Column  PGInt4       )
-                                  (Column  PGInt4       )
-                           (Maybe (Column  PGInt4       ))
-                                  (Column PGText        )
-                           (Maybe (Column  PGTimestamptz))
-                                  (Column  PGJsonb      )
-
-type NodeRead = NodePoly  (Column PGInt4        )
-                          (Column PGInt4        )
-                          (Column PGInt4        )
-                          (Column PGInt4        )
-                          (Column PGText        )
-                          (Column PGTimestamptz )
-                          (Column PGJsonb       )
-
-type NodeReadNull = NodePoly  (Column (Nullable PGInt4 ))
-                              (Column (Nullable PGInt4 ))
-                              (Column (Nullable PGInt4 ))
-                              (Column (Nullable PGInt4 ))
-                              (Column (Nullable PGText ))
-                              (Column (Nullable PGTimestamptz ))
-                              (Column (Nullable PGJsonb))
+type NodeWrite = NodePoly (Maybe (Column PGInt4)      )
+                                 (Column PGInt4)
+                                 (Column PGInt4)
+                          (Maybe (Column PGInt4)      )
+                                 (Column PGText)
+                          (Maybe (Column PGTimestamptz))
+                                 (Column PGJsonb)
+
+type NodeRead = NodePoly (Column PGInt4        )
+                         (Column PGInt4        )
+                         (Column PGInt4        )
+                         (Column PGInt4        )
+                         (Column PGText        )
+                         (Column PGTimestamptz )
+                         (Column PGJsonb       )
+
+type NodeReadNull = NodePoly (Column (Nullable PGInt4))
+                             (Column (Nullable PGInt4))
+                             (Column (Nullable PGInt4))
+                             (Column (Nullable PGInt4))
+                             (Column (Nullable PGText))
+                             (Column (Nullable PGTimestamptz))
+                             (Column (Nullable PGJsonb))
 
 nodeTable :: Table NodeWrite NodeRead
 nodeTable = Table "nodes" (pNode Node { _node_id         = optional "id"
@@ -201,32 +202,38 @@ queryNodeTable = queryTable nodeTable
 ------------------------------------------------------------------------
 -- | Node(Read|Write)Search is slower than Node(Write|Read) use it
 -- for full text search only
-type NodeSearchWrite = NodePolySearch  (Maybe (Column  PGInt4              ))
-                                  (Column  PGInt4               )
-                                  (Column  PGInt4               )
-                                  (Column (Nullable PGInt4     ))
-                                  (Column (PGText              ))
-                                  (Maybe  (Column PGTimestamptz))
-                                  (Column  PGJsonb              )
-                                  (Maybe (Column PGTSVector))
-
-type NodeSearchRead = NodePolySearch  (Column  PGInt4           )
-                          (Column  PGInt4           )
-                          (Column  PGInt4           )
-                          (Column (Nullable PGInt4 ))
-                          (Column (PGText          ))
-                          (Column PGTimestamptz     )
-                          (Column PGJsonb) 
-                          (Column PGTSVector)
-
-type NodeSearchReadNull = NodePolySearch  (Column  (Nullable PGInt4           ))
-                              (Column  (Nullable PGInt4           ))
-                              (Column  (Nullable PGInt4           ))
-                              (Column (Nullable PGInt4 ))
-                              (Column (Nullable PGText          ))
-                              (Column (Nullable PGTimestamptz     ))
-                              (Column (Nullable PGJsonb))
-                              (Column (Nullable PGTSVector))
+type NodeSearchWrite =
+  NodePolySearch
+    (Maybe  (Column  PGInt4)      )
+    (Column  PGInt4               )
+    (Column  PGInt4               )
+    (Column (Nullable PGInt4)     )
+    (Column PGText                )
+    (Maybe  (Column PGTimestamptz))
+    (Column  PGJsonb              )
+    (Maybe  (Column PGTSVector)   )
+
+type NodeSearchRead =
+  NodePolySearch
+    (Column  PGInt4           )
+    (Column  PGInt4           )
+    (Column  PGInt4           )
+    (Column (Nullable PGInt4 ))
+    (Column  PGText           )
+    (Column  PGTimestamptz    )
+    (Column  PGJsonb          )
+    (Column  PGTSVector       )
+
+type NodeSearchReadNull =
+  NodePolySearch
+    (Column (Nullable PGInt4)       )
+    (Column (Nullable PGInt4)       )
+    (Column (Nullable PGInt4)       )
+    (Column (Nullable PGInt4)       )
+    (Column (Nullable PGText)       )
+    (Column (Nullable PGTimestamptz))
+    (Column (Nullable PGJsonb)      )
+    (Column (Nullable PGTSVector)   )
 
 --{-
 nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
@@ -336,7 +343,8 @@ type JSONB = QueryRunnerColumnDefault PGJsonb
 
 getNode :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
 getNode nId _ = do
-    fromMaybe (error $ "Node does node exist: " <> show nId) . headMay <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
+    fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
+             <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 
 getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
 getNodesWithType = runOpaQuery . selectNodesWithType
@@ -502,13 +510,16 @@ childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a c
 
 type Name = Text
 
+-- | TODO mk all others nodes
 mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
-mkNodeWithParent NodeUser (Just _) _   _     = nodeError UserNoParent
-mkNodeWithParent _        Nothing  _   _     = nodeError HasParent
-mkNodeWithParent nt       pId     uId name   =
-    insertNodesWithParentR pId [node nt name hd pId uId]
-  where
-    hd = HyperdataUser . Just . pack $ show EN
+mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
+mkNodeWithParent NodeUser Nothing  uId name =
+  insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
+    where
+      hd = HyperdataUser . Just . pack $ show EN
+mkNodeWithParent _ Nothing _ _ = nodeError HasParent
+mkNodeWithParent _ _ _ _ = nodeError NotImplYet
+
 
 mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
 mkRoot uname uId = case uId > 0 of

src/Gargantext/Database/Schema/schema.sql

 CREATE EXTENSION IF NOT EXISTS plpgsql WITH SCHEMA pg_catalog;
 COMMENT ON EXTENSION plpgsql IS 'PL/pgSQL procedural language';
--- needed for rights management
--- CREATE EXTENSION IF NOT EXISTS acl WITH SCHEMA public;
 
 -- CREATE USER WITH ...
 -- createdb "gargandb"
@@ -23,6 +21,7 @@ CREATE TABLE public.auth_user (
 
 ALTER TABLE public.auth_user OWNER TO gargantua;
 
+
 -- TODO add publication_date
 -- TODO typename -> type_id
 CREATE TABLE public.nodes (
@@ -40,7 +39,6 @@ CREATE TABLE public.nodes (
 ALTER TABLE public.nodes OWNER TO gargantua;
 
 
-
 CREATE TABLE public.ngrams (
     id SERIAL,
     terms character varying(255),
@@ -49,7 +47,9 @@ CREATE TABLE public.ngrams (
 );
 ALTER TABLE public.ngrams OWNER TO gargantua;
 
--- TODO: delete ID
+--------------------------------------------------------------
+--------------------------------------------------------------
+-- TODO: delete delete this table
 CREATE TABLE public.nodes_ngrams (
     id SERIAL,
     node_id integer NOT NULL,
@@ -64,13 +64,21 @@ CREATE TABLE public.nodes_ngrams (
     -- PRIMARY KEY (node_id,ngrams_id)
 );
 ALTER TABLE public.nodes_ngrams OWNER TO gargantua;
+--------------------------------------------------------------
 
+CREATE TABLE public.nodes_ngrams_repo (
+    version integer NOT NULL,
+    patches jsonb DEFAULT '{}'::jsonb NOT NULL,
+    PRIMARY KEY (version)
+);
+ALTER TABLE public.nodes_ngrams_repo OWNER TO gargantua;
+
+--------------------------------------------------------------
 --
--- Name: nodes_ngrams_ngrams; Type: TABLE; Schema: public; Owner: gargantua
 --
-
+-- TODO: delete delete this table
 CREATE TABLE public.nodes_ngrams_ngrams (
-    node_id integer NOT NULL REFERENCES public.nodes(id) ON DELETE CASCADE,
+    node_id   integer NOT NULL REFERENCES public.nodes(id)  ON DELETE CASCADE,
     ngram1_id integer NOT NULL REFERENCES public.ngrams(id) ON DELETE CASCADE,
     ngram2_id integer NOT NULL REFERENCES public.ngrams(id) ON DELETE CASCADE,
     weight double precision,
@@ -79,7 +87,7 @@ CREATE TABLE public.nodes_ngrams_ngrams (
 
 ALTER TABLE public.nodes_ngrams_ngrams OWNER TO gargantua;
 
-
+---------------------------------------------------------
 CREATE TABLE public.nodes_nodes (
     node1_id integer NOT NULL,
     node2_id integer NOT NULL,
@@ -89,8 +97,23 @@ CREATE TABLE public.nodes_nodes (
     PRIMARY KEY (node1_id, node2_id)
 );
 ALTER TABLE public.nodes_nodes OWNER TO gargantua;
+---------------------------------------------------------
+
+-- If needed for rights management at row level
+-- CREATE EXTENSION IF NOT EXISTS acl WITH SCHEMA public;
+
+CREATE TABLE public.rights (
+  user_id INTEGER NOT NULL REFERENCES public.auth_user(id) ON DELETE CASCADE,
+  node_id INTEGER NOT NULL REFERENCES public.nodes(id)     ON DELETE CASCADE,
+  rights  INTEGER NOT NULL,
+  PRIMARY KEY (user_id, node_id)
+);
+ALTER TABLE public.rights OWNER TO gargantua;
+
+CREATE INDEX rights_userId_nodeId ON public.rights USING btree (user_id,node_id);
 
 
+------------------------------------------------------------
 -- INDEXES
 CREATE UNIQUE INDEX ON public.auth_user(username);
 

src/Gargantext/Database/Types/Node.hs

@@ -28,8 +28,7 @@ import Prelude (Enum, Bounded, minBound, maxBound)
 
 import GHC.Generics (Generic)
 
-import           Control.Lens hiding (elements)
-import qualified Control.Lens   as L
+import           Control.Lens hiding (elements, (&))
 import           Control.Applicative ((<*>))
 import           Control.Monad (mzero)
 
@@ -41,7 +40,7 @@ import           Data.ByteString.Lazy (ByteString)
 import           Data.Either
 import           Data.Eq (Eq)
 import           Data.Monoid (mempty)
-import           Data.Text (Text, unpack)
+import           Data.Text (Text, unpack, pack)
 import           Data.Time (UTCTime)
 import           Data.Time.Segment (jour, timesAfter, Granularity(D))
 import           Data.Swagger
@@ -61,7 +60,7 @@ import           Gargantext.Core.Utils.Prefix (unPrefix)
 --import Gargantext.Database.Utils
 ------------------------------------------------------------------------
 newtype NodeId = NodeId Int
-  deriving (Show, Read, Generic, Num, Eq, Ord, Enum)
+  deriving (Show, Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON)
 
 instance ToField NodeId where
   toField (NodeId n) = toField n
@@ -72,8 +71,6 @@ instance FromField NodeId where
     if (n :: Int) > 0 then return $ NodeId n
                       else mzero
 
-instance ToJSON NodeId
-instance FromJSON NodeId
 instance ToSchema NodeId
 
 instance FromHttpApiData NodeId where
@@ -237,11 +234,8 @@ instance ToSchema Event where
   declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
 
 ------------------------------------------------------------------------
-
-type Text' = Text
-
-instance Arbitrary Text' where
-  arbitrary = elements ["ici", "la"]
+instance Arbitrary Text where
+  arbitrary = elements $ map (\c -> pack [c]) ['a'..'z']
 
 data Resource = Resource { resource_path    :: Maybe Text
                          , resource_scraper :: Maybe Text
@@ -324,6 +318,10 @@ data HyperdataList = HyperdataList { hyperdataList_preferences   :: Maybe Text
 $(deriveJSON (unPrefix "hyperdataList_") ''HyperdataList)
 
 instance Hyperdata HyperdataList
+
+instance Arbitrary HyperdataList where
+  arbitrary = elements [HyperdataList (Just "from list A")]
+
 ------------------------------------------------------------------------
 data HyperdataScore = HyperdataScore { hyperdataScore_preferences   :: Maybe Text
                                    } deriving (Show, Generic)
@@ -500,27 +498,24 @@ docExample = "{\"doi\":\"sdfds\",\"publication_day\":6,\"language_iso2\":\"en\",
 
 instance ToSchema HyperdataCorpus where
   declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
-    L.& mapped.schema.description ?~ "a corpus"
-    L.& mapped.schema.example ?~ toJSON hyperdataCorpus
-
+    & mapped.schema.description ?~ "a corpus"
+    & mapped.schema.example ?~ toJSON hyperdataCorpus
 
 instance ToSchema HyperdataAnnuaire where
   declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
-    L.& mapped.schema.description ?~ "an annuaire"
-    L.& mapped.schema.example ?~ toJSON hyperdataAnnuaire
-
+    & mapped.schema.description ?~ "an annuaire"
+    & mapped.schema.example ?~ toJSON hyperdataAnnuaire
 
 instance ToSchema HyperdataDocument where
   declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
-    L.& mapped.schema.description ?~ "a document"
-    L.& mapped.schema.example ?~ toJSON hyperdataDocument
-
+    & mapped.schema.description ?~ "a document"
+    & mapped.schema.example ?~ toJSON hyperdataDocument
 
 instance ToSchema HyperdataAny where
   declareNamedSchema proxy =
     pure $ genericNameSchema defaultSchemaOptions proxy mempty
-             L.& schema.description ?~ "a node"
-             L.& schema.example ?~ emptyObject -- TODO
+             & schema.description ?~ "a node"
+             & schema.example ?~ emptyObject -- TODO
 
 
 instance ToSchema hyperdata =>

src/Gargantext/Database/Utils.hs

@@ -37,7 +37,6 @@ import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(Conversion
 import Database.PostgreSQL.Simple.Internal  (Field)
 import Gargantext.Prelude
 import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
-import Servant (ServantErr)
 import System.IO (FilePath)
 import Text.Read (read)
 import qualified Data.ByteString      as DB
@@ -49,13 +48,19 @@ class HasConnection env where
 instance HasConnection Connection where
   connection = identity
 
-type CmdM env err m =
+type CmdM' env err m =
   ( MonadReader env m
-  , HasConnection env
   , MonadError err m
   , MonadIO m
   )
 
+type CmdM env err m =
+  ( CmdM' env err m
+  , HasConnection env
+  )
+
+type Cmd' env err a = forall m. CmdM' env err m => m a
+
 type Cmd err a = forall m env. CmdM env err m => m a
 
 -- TODO: ideally there should be very few calls to this functions.
@@ -64,22 +69,10 @@ mkCmd k = do
   conn <- view connection
   liftIO $ k conn
 
-runCmd :: Connection -> Cmd err a -> IO (Either err a)
-runCmd conn m = runExceptT $ runReaderT m conn
-
--- Use only for dev
-runCmdDevWith :: FilePath -> Cmd ServantErr a -> IO a
-runCmdDevWith fp f = do
-  conn <- connectGargandb fp
-  either (fail . show) pure =<< runCmd conn f
-
--- Use only for dev
-runCmdDev :: Cmd ServantErr a -> IO a
-runCmdDev = runCmdDevWith "gargantext.ini"
-
--- Use only for dev
-runCmdDevNoErr :: Cmd () a -> IO a
-runCmdDevNoErr = runCmdDevWith "gargantext.ini"
+runCmd :: HasConnection env => env
+       -> Cmd' env err a
+       -> IO (Either err a)
+runCmd env m = runExceptT $ runReaderT m env
 
 runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
 runOpaQuery q = mkCmd $ \c -> runQuery c q

src/Gargantext/Text/Flow.hs

@@ -43,6 +43,7 @@ import Gargantext.Text.Terms (TermType, extractTerms)
 import Gargantext.Viz.Graph (Graph(..), data2graph)
 import Gargantext.Viz.Graph.Bridgeness (bridgeness)
 import Gargantext.Viz.Graph.Distances.Matrice (measureConditional)
+--import Gargantext.Viz.Graph.Distances.Matrice (distributional)
 import Gargantext.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map)
 {-
   ____                             _            _
@@ -153,7 +154,7 @@ cooc2graph myCooc = do
 
 --  let distance = fromIndex fi distanceMap
   --printDebug "distance" $ M.size distance
-  
+
   partitions <- case M.size distanceMap > 0 of
                   True  -> cLouvain distanceMap
                   False -> panic "Text.Flow: DistanceMap is empty"

src/Gargantext/Text/Metrics.hs

@@ -63,7 +63,7 @@ filterCooc' (FilterConfig _ _ _ _ (DefaultValue dv)) ts m = trace ("coocScored "
   where
     selection  = [(x,y) | x <- ts
                         , y <- ts
-                      --  , x >= y
+                        , x > y
                         ]
 
 

src/Gargantext/Viz/Phylo.hs

@@ -7,7 +7,7 @@ Maintainer  : team@gargantext.org
 Stability   : experimental
 Portability : POSIX
 
-Specifications of Phylomemy format.
+Specifications of Phylomemy export format.
 
 Phylomemy can be described as a Temporal Graph with different scale of
 granularity of group of ngrams (terms and multi-terms).
@@ -39,9 +39,9 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Prelude
 
 ------------------------------------------------------------------------
-data PhyloFormat =
-     PhyloFormat { _phyloFormat_param :: PhyloParam
-                 , _phyloFormat_data :: Phylo
+data PhyloExport =
+     PhyloExport { _phyloExport_param :: PhyloParam
+                 , _phyloExport_data :: Phylo
      } deriving (Generic)
 
 -- | .phylo parameters
@@ -66,7 +66,7 @@ data Software =
 -- Ngrams   : list of all (possible) terms contained in the phylomemy (with their id)
 -- Steps    : list of all steps to build the phylomemy
 data Phylo =
-     Phylo { _phylo_puration :: (Start, End)
+     Phylo { _phylo_duration :: (Start, End)
            , _phylo_ngrams   :: [Ngram]
            , _phylo_periods  :: [PhyloPeriod]
            }
@@ -109,27 +109,28 @@ type PhyloLevelId = (PhyloPeriodId, Int)
 -- Ngrams: set of terms that build the group
 -- Period Parents|Childs: weighted link to Parents|Childs (Temporal Period   axis)
 -- Level  Parents|Childs: weighted link to Parents|Childs (Level Granularity axis)
+-- Pointers are directed link from Self to any PhyloGroup (/= Self ?)
 data PhyloGroup =
      PhyloGroup { _phylo_groupId    :: PhyloGroupId
                 , _phylo_groupLabel :: Maybe Text
                 , _phylo_groupNgrams        :: [NgramsId]
                 
-                , _phylo_groupPeriodParents :: [Edge]
-                , _phylo_groupPeriodChilds  :: [Edge]
+                , _phylo_groupPeriodParents :: [Pointer]
+                , _phylo_groupPeriodChilds  :: [Pointer]
                 
-                , _phylo_groupLevelParents  :: [Edge]
-                , _phylo_groupLevelChilds   :: [Edge]
+                , _phylo_groupLevelParents  :: [Pointer]
+                , _phylo_groupLevelChilds   :: [Pointer]
                 }
                 deriving (Generic)
 
 type PhyloGroupId = (PhyloLevelId, Int)
-type Edge         = (PhyloGroupId, Weight)
+type Pointer      = (PhyloGroupId, Weight)
 type Weight       = Double
 
 -- | Lenses
 makeLenses ''Phylo
 makeLenses ''PhyloParam
-makeLenses ''PhyloFormat
+makeLenses ''PhyloExport
 makeLenses ''Software
 
 -- | JSON instances
@@ -138,9 +139,9 @@ $(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod )
 $(deriveJSON (unPrefix "_phylo_level"  ) ''PhyloLevel  )
 $(deriveJSON (unPrefix "_phylo_group"  ) ''PhyloGroup  )
 -- 
-$(deriveJSON (unPrefix "_software_"  ) ''Software )
+$(deriveJSON (unPrefix "_software_"    ) ''Software    )
 $(deriveJSON (unPrefix "_phyloParam_"  ) ''PhyloParam  )
-$(deriveJSON (unPrefix "_phyloFormat_" ) ''PhyloFormat  )
+$(deriveJSON (unPrefix "_phyloExport_" ) ''PhyloExport )
 
 -- | TODO XML instances
 

src/Gargantext/Viz/Phylo/Tools.hs

+{-|
+Module      : Gargantext.Viz.Phylo.Tools
+Description : Phylomemy tools
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Phylo Toolbox:
+- functions to build a Phylo
+- functions to filter the cliques
+- functions to manage a Phylo
+
+Group Functions (TODO list)
+- cohesion sur un groupe
+- distance au dernier branchement
+- âge du groupe
+
+Futre Idea: temporal zoom on Phylo
+phyloZoomOut :: (PeriodGrain, Phylo) -> [(PeriodGrain, Phylo)]
+(from smallest granularity, it increases (zoom out) the periods of the Phylo)
+Moral idea: viz from out to in
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gargantext.Viz.Phylo.Tools where
+
+import Data.Set (Set)
+import Data.Map (Map)
+import Data.Map as Map hiding (Map)
+import Gargantext.Prelude
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Example
+
+-- | Some types to help reading
+type Clique = Set Ngrams
+type Support = Int
+type MinSize = Int
+
+-- | Building a phylo
+-- (Indicative and schematic function)
+buildPhylo :: Support -> MinSize
+                      -> Map Clique Support -> Phylo
+buildPhylo s m mcs = level2Phylo
+                   . groups2level
+                   . clusters2group
+                   . map clique2cluster
+                   . filterCliques s m
+
+level2Phylo :: PhyloLevel -> Phylo -> Phylo
+level2Phylo = undefined
+
+groups2level :: [PhyloGroup] -> PhyloLevel
+groups2level = undefined
+
+clusters2group :: [Cluster Ngrams] -> PhyloGroup
+clusters2group = undefined
+
+clique2cluster :: Clique -> Cluster Ngrams
+clique2cluster = undefined
+
+-- | Filtering the cliques before bulding the Phylo
+-- (Support and MinSize as parameter of the finale function to build a phylo)
+-- idea: log of Corpus size (of docs)
+filterCliques :: Support -> MinSize
+                         -> Map Clique Support -> [Clique]
+filterCliques s ms = maximalCliques
+                   . filterWithSizeSet ms
+                   . Map.keys
+                   . filterWithSupport s
+
+-- | Hapaxify / Threshold
+-- hapax s = 1
+-- ?  
+filterWithSupport :: Support -> Map Clique Support -> Map Clique Support
+filterWithSupport s = Map.filter (>s)
+
+filterWithSizeSet :: MinSize -> [Clique] -> [Clique]
+filterWithSizeSet = undefined
+
+-- | filtre les cliques de ngrams compris dans une clique plus grande
+-- /!\ optim inside
+maximalCliques :: [Clique] -> [Clique]
+maximalCliques = undefined
+
+
+
+
+-- | Phylo management
+
+-- | PhyloLevel Management
+viewGroups :: (Start,End) -> PhyloLevel -> Phylo -> [PhyloGroup]
+viewGroups = undefined
+
+viewLevels :: (Start,End) -> Phylo -> [PhyloLevel]
+viewLevels = undefined
+
+-- | tous les terme des champs, tous les parents et les enfants
+setGroup :: PhyloGroup -> PhyloGroup -> PhyloGroup
+setGroup = undefined
+--removeTerms :: recalculer les cliques pour ces termes
+--addTerms 
+

stack.yaml

@@ -12,6 +12,8 @@ packages:
 
 allow-newer: true
 extra-deps:
+- json-state-0.1.0.1
+- time-units-1.0.0
 - git: https://github.com/delanoe/data-time-segment.git
   commit: 4e3d57d80e9dfe6624c8eeaa8595fc8fe64d8723
 - git: https://gitlab.iscpif.fr/gargantext/hlcm.git
@@ -34,4 +36,4 @@ extra-deps:
 - servant-flatten-0.2
 - servant-multipart-0.11.2
 - stemmer-0.5.2
-- validity-0.8.0.0 # patches-{map,class}
+- validity-0.9.0.0 # patches-{map,class}