[FUN] from old repo to new NodeStory

src/Gargantext/API/Admin/Settings.hs

@@ -27,6 +27,14 @@ import Control.Monad.Reader
 import Data.Maybe (fromMaybe)
 import Data.Pool (Pool, createPool)
 import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
+import Gargantext.API.Admin.EnvTypes
+import Gargantext.API.Admin.Types
+import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
+import Gargantext.Core.NodeStory
+import Gargantext.Core.Types (NodeId)
+import Gargantext.Database.Prelude (databaseParameters, HasConfig(..))
+import Gargantext.Prelude
+import Gargantext.Prelude.Config (GargConfig(..), gc_repofilepath, readConfig)
 import Network.HTTP.Client.TLS (newTlsManager)
 import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSettings(..), defaultCookieSettings, defaultXsrfCookieSettings, readKey, writeKey)
 import Servant.Client (parseBaseUrl)
@@ -38,14 +46,6 @@ import System.IO.Temp (withTempFile)
 import System.Log.FastLogger
 import qualified Data.ByteString.Lazy as L
 
-import Gargantext.Core.Types (NodeId)
-import Gargantext.API.Admin.EnvTypes
-import Gargantext.API.Admin.Types
-import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
-import Gargantext.Database.Prelude (databaseParameters, HasConfig(..))
-import Gargantext.Prelude
-import Gargantext.Prelude.Config (GargConfig(..), gc_repofilepath, readConfig)
-
 devSettings :: FilePath -> IO Settings
 devSettings jwkFile = do
   jwkExists <- doesFileExist jwkFile
@@ -114,15 +114,6 @@ repoSaverAction repoDir a = do
     renameFile fp (repoSnapshot repoDir)
 
 
-repoSaverAction' :: RepoDirFilePath -> NgramsRepo -> IO ()
-repoSaverAction' repoDir a = do
-  withTempFile "repos" "tmp-repo.cbor" $ \fp h -> do
-    printDebug "repoSaverAction" fp
-    L.hPut h $ serialise a
-    hClose h
-    renameFile fp (repoSnapshot repoDir)
-
-
 
 -- The use of mkDebounce makes sure that repoSaverAction is not called too often.
 -- If repoSaverAction start taking more time than the debounceFreq then it should

src/Gargantext/API/Admin/Types.hs

@@ -9,10 +9,10 @@ import Control.Monad.Logger
 import Data.ByteString (ByteString)
 import GHC.Enum
 import GHC.Generics (Generic)
+import Gargantext.Prelude
 import Servant.Auth.Server (JWTSettings, CookieSettings(..))
 import Servant.Client (BaseUrl)
 
-import Gargantext.Prelude
 
 type PortNumber = Int
 
@@ -42,4 +42,4 @@ class HasSettings env where
 instance HasSettings Settings where
   settings = identity
 
-data FireWall = FireWall { unFireWall :: Bool }
\ No newline at end of file
+data FireWall = FireWall { unFireWall :: Bool }

src/Gargantext/API/Ngrams/Types.hs

@@ -681,6 +681,7 @@ data Repo s p = Repo
 
 -- | TO REMOVE
 type NgramsRepo       = Repo     NgramsState NgramsStatePatch
+
 type NgramsState      = Map      TableNgrams.NgramsType (Map NodeId NgramsTableMap)
 type NgramsStatePatch = PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch)
 

src/Gargantext/Core/NodeStory.hs

@@ -9,15 +9,19 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE TemplateHaskell   #-}
 
 module Gargantext.Core.NodeStory where
 
-
+import Data.Maybe (fromMaybe)
 import Codec.Serialise (Serialise())
+import System.FileLock (FileLock)
+import Control.Concurrent (MVar())
 import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~))
 import Data.Aeson hiding ((.=))
 import Data.IntMap (IntMap)
 import Data.IntMap as Bibliotheque
+import qualified Data.List as List
 import Data.Map (Map)
 import Data.Map as Map
 import Data.Monoid
@@ -28,13 +32,45 @@ import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger
 import Gargantext.Prelude
 import qualified Data.IntMap as Dict
 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
+import qualified Data.Map.Strict.Patch.Internal as Patch
+
+
+------------------------------------------------------------------------
+-- TODO : repo Migration TODO TESTS
+repoMigration :: NgramsRepo -> NodeListStory
+repoMigration (Repo _v s h) = NodeStory $ Map.fromList ns
+  where
+    s' = ngramsState_migration      s
+    h' = ngramsStatePatch_migration h
+    ns = List.map (\(n,ns)
+                    -> (n, let hs = fromMaybe [] (Map.lookup n h') in
+                               Archive (List.length hs) ns hs
+                       )
+                  ) s'
+
+ngramsState_migration :: NgramsState
+                      -> [(NodeId,NgramsState')]
+ngramsState_migration ns =
+    [ (nid, Map.singleton nt table)
+    | (nt, nTable) <- Map.toList ns
+    , (nid, table) <- Map.toList nTable
+    ]
+
+ngramsStatePatch_migration :: [NgramsStatePatch]
+                           -> Map NodeId [NgramsStatePatch']
+ngramsStatePatch_migration np' = Map.fromListWith (<>)
+    [ (nid, [fst $ Patch.singleton nt table])
+    | np <- np'
+    , (nt, nTable) <- Patch.toList np
+    , (nid, table) <- Patch.toList nTable
+    ]
+------------------------------------------------------------------------
 
--- TODO : repo Migration
-repoMigration :: (s -> s') -> (p -> p') -> Repo s p -> NodeStory s' p'
-repoMigration = undefined
 
--- Key is NodeId
--- | Node Story for each NodeType
+{- | Node Story for each NodeType where the Key of the Map is NodeId
+  TODO : generalize for any NodeType, let's start with NodeList which
+  is implemented already
+-}
 data NodeStory s p = NodeStory { unNodeStory :: Map NodeId (Archive s p) }
   deriving (Generic, Show)
 
@@ -68,16 +104,16 @@ instance (ToJSON s, ToJSON p) => ToJSON (Archive s p) where
 
 ------------------------------------------------------------------------
 initNodeStory :: Monoid s => NodeStory s p
-initNodeStory = NodeStory $ Map.singleton 1 initArchive
+initNodeStory = NodeStory $ Map.singleton 0 initArchive
 
 initArchive :: Monoid s => Archive s p
-initArchive = Archive 1 mempty []
+initArchive = Archive 0 mempty []
 
 initNodeListStoryMock :: NodeListStory
 initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
   where
     nodeListId = 10
-    archive        = Archive 1 ngramsTableMap []
+    archive        = Archive 0 ngramsTableMap []
     ngramsTableMap = Map.singleton TableNgrams.NgramsTerms
                    $ Map.fromList
                    [ (n ^. ne_ngrams, ngramsElementToRepo n)
@@ -85,8 +121,23 @@ initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
                    ]
 
 ------------------------------------------------------------------------
-{-
 data NodeStoryEnv = NodeStoryEnv
-  { _nse_var :: !(MVar
--}
+  { _nse_var :: !(IO (MVar NodeListStory))
+  , _nse_saver :: !(IO ())
+  , _nse_lock  :: !FileLock
+  }
+  deriving (Generic)
+
+makeLenses ''NodeStoryEnv
+
+class HasNodeStoryEnv env where
+  nodeStoryEnv :: env -> IO (MVar NodeListStory)
+
+instance HasNodeStoryEnv (MVar NodeListStory) where
+  nodeStoryEnv = pure
+
+
+class HasNodeStorySaver env where
+  nodeStorySaver :: Getter env (IO ())
+