[FIX] repo migration fixed (WIP)

package.yaml

@@ -121,6 +121,7 @@ library:
   - case-insensitive
   - cassava
   - cereal     # (IGraph)
+  - cborg
   - conduit
   - conduit-extra
   - containers

src/Gargantext/API/Admin/EnvTypes.hs

@@ -14,6 +14,7 @@ import Servant.Job.Async (HasJobEnv(..), Job)
 import System.Log.FastLogger
 import qualified Servant.Job.Core
 
+import Gargantext.API.Ngrams.Types (HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..))
 import Gargantext.API.Admin.Types
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
@@ -25,6 +26,7 @@ data Env = Env
   { _env_settings  :: !Settings
   , _env_logger    :: !LoggerSet
   , _env_pool      :: !(Pool Connection)
+  , _env_repo      :: !RepoEnv
   , _env_nodeStory :: !NodeStoryEnv
   , _env_manager   :: !Manager
   , _env_self_url  :: !BaseUrl
@@ -53,6 +55,14 @@ instance HasNodeStorySaver Env where
 instance HasSettings Env where
   settings = env_settings
 
+-- Specific to Repo
+instance HasRepoVar Env where
+  repoVar = repoEnv . repoVar
+instance HasRepoSaver Env where
+  repoSaver = repoEnv . repoSaver
+instance HasRepo Env where
+  repoEnv = env_repo
+
 
 
 
@@ -71,9 +81,9 @@ makeLenses ''MockEnv
 
 
 
-
 data DevEnv = DevEnv
   { _dev_env_settings  :: !Settings
+  , _dev_env_repo      :: !RepoEnv
   , _dev_env_config    :: !GargConfig
   , _dev_env_pool      :: !(Pool Connection)
   , _dev_env_nodeStory :: !NodeStoryEnv
@@ -91,7 +101,6 @@ instance HasSettings DevEnv where
   settings = dev_env_settings
 
 
-
 instance HasNodeStoryEnv DevEnv where
   hasNodeStory = dev_env_nodeStory
 
@@ -101,3 +110,12 @@ instance HasNodeStoryVar DevEnv where
 instance HasNodeStorySaver DevEnv where
   hasNodeStorySaver = hasNodeStory . nse_saver
 
+
+instance HasRepoVar DevEnv where
+  repoVar = repoEnv . repoVar
+instance HasRepoSaver DevEnv where
+  repoSaver = repoEnv . repoSaver
+instance HasRepo DevEnv where
+  repoEnv = dev_env_repo
+
+

src/Gargantext/API/Admin/Settings.hs

@@ -18,32 +18,36 @@ TODO-SECURITY: Critical
 module Gargantext.API.Admin.Settings
     where
 
-import Codec.Serialise (Serialise(), serialise{-, deserialise-})
--- import Control.Concurrent
--- import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
+import Codec.Serialise (Serialise(), serialise, deserialise)
+import Control.Concurrent
+import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
 import Control.Lens
 import Control.Monad.Logger
 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.Core.NodeStory
-import Gargantext.Database.Prelude (databaseParameters)
-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)
 import Servant.Job.Async (newJobEnv, defaultSettings)
 import System.Directory
--- import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
+import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
 import System.IO (FilePath, hClose)
 import System.IO.Temp (withTempFile)
 import System.Log.FastLogger
 import qualified Data.ByteString.Lazy as L
 
+
+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 (gc_repofilepath)
+
 devSettings :: FilePath -> IO Settings
 devSettings jwkFile = do
   jwkExists <- doesFileExist jwkFile
@@ -109,7 +113,7 @@ repoSaverAction repoDir a = do
 
 
 
-{-
+--{-
 -- 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
 -- be increased.
@@ -158,7 +162,7 @@ readRepoEnv repoDir = do
   -- TODO save in DB here
   saver <- mkRepoSaver repoDir mvar
   pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
--}
+--}
 
 devJwkFile :: FilePath
 devJwkFile = "dev.jwk"
@@ -174,7 +178,7 @@ newEnv port file = do
   self_url_env  <- parseBaseUrl $ "http://0.0.0.0:" <> show port
   dbParam       <- databaseParameters file
   pool          <- newPool dbParam
---  repo          <- readRepoEnv (_gc_repofilepath config_env)
+  repo          <- readRepoEnv (_gc_repofilepath config_env)
   nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
   scrapers_env  <- newJobEnv defaultSettings manager_env
   logger        <- newStderrLoggerSet defaultBufSize
@@ -183,7 +187,7 @@ newEnv port file = do
     { _env_settings  = settings'
     , _env_logger    = logger
     , _env_pool      = pool
---    , _env_repo      = repo
+    , _env_repo      = repo
     , _env_nodeStory = nodeStory_env
     , _env_manager   = manager_env
     , _env_scrapers  = scrapers_env
@@ -194,10 +198,10 @@ newEnv port file = do
 newPool :: ConnectInfo -> IO (Pool Connection)
 newPool param = createPool (connect param) close 1 (60*60) 8
 
-{-
+--{-
 cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
 cleanEnv env = do
   r <- takeMVar (env ^. repoEnv . renv_var)
   repoSaverAction (env ^. hasConfig . gc_repofilepath) r
   unlockFile (env ^. repoEnv . renv_lock)
--}
+--}

src/Gargantext/API/Dev.hs

@@ -31,8 +31,7 @@ type IniPath  = FilePath
 withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
 withDevEnv iniPath k = do
   env <- newDevEnv
-  k env
-  -- k env `finally` cleanEnv env
+  k env `finally` cleanEnv env
 
   where
     newDevEnv = do
@@ -40,9 +39,11 @@ withDevEnv iniPath k = do
       dbParam <- databaseParameters iniPath
       nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
       pool    <- newPool            dbParam
+      repo    <- readRepoEnv        (_gc_repofilepath cfg)
       setts   <- devSettings devJwkFile
       pure $ DevEnv
         { _dev_env_pool     = pool
+        , _dev_env_repo     = repo
         , _dev_env_nodeStory  = nodeStory_env
         , _dev_env_settings = setts
         , _dev_env_config   = cfg

src/Gargantext/API/Ngrams/Tools.hs

@@ -36,6 +36,13 @@ mergeNgramsElement _neOld neNew = neNew
 
 type RootTerm = NgramsTerm
 
+
+getRepo :: RepoCmdM env err m => m NgramsRepo
+getRepo = do
+  v <- view repoVar
+  liftBase $ readMVar v
+
+
 getRepo' :: HasNodeStory env err m
          => [ListId] -> m NodeListStory
 getRepo' listIds = do

src/Gargantext/API/Ngrams/Types.hs

@@ -12,7 +12,7 @@ module Gargantext.API.Ngrams.Types where
 import Codec.Serialise (Serialise())
 import Control.Category ((>>>))
 import Control.Concurrent
-import Control.Lens (makeLenses, makePrisms, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~))
+import Control.Lens (makeLenses, makePrisms, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~), Getter)
 import Control.Monad.State
 import Data.Aeson hiding ((.=))
 import Data.Aeson.TH (deriveJSON)
@@ -33,7 +33,7 @@ import GHC.Generics (Generic)
 import Gargantext.Core.Text (size)
 import Gargantext.Core.Types (ListType(..), ListId, NodeId, TODO)
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger, wellNamedSchema)
-import Gargantext.Database.Prelude (fromField')
+import Gargantext.Database.Prelude (fromField', HasConnectionPool, HasConfig, CmdM')
 import Gargantext.Prelude
 import Gargantext.Prelude.Crypto.Hash (IsHashable(..))
 import Protolude (maybeToEither)
@@ -719,7 +719,6 @@ data RepoEnv = RepoEnv
 
 makeLenses ''RepoEnv
 
-{-
 type RepoCmdM   env err m =
   ( CmdM'             env err m
   , HasRepo           env
@@ -744,7 +743,6 @@ instance HasRepoVar RepoEnv where
   repoVar = renv_var
 instance HasRepoSaver RepoEnv where
   repoSaver = renv_saver
--}
 
 ------------------------------------------------------------------------
 

src/Gargantext/Core/NodeStory.hs

@@ -15,13 +15,15 @@ Portability : POSIX
 
 module Gargantext.Core.NodeStory where
 
-import Codec.Serialise (Serialise(), serialise, deserialise)
+-- import Debug.Trace (traceShow)
+import Codec.Serialise (serialise, deserialise)
+import Codec.Serialise.Class 
 import Control.Concurrent (MVar(), withMVar, newMVar)
 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
 import Control.Lens (makeLenses, Getter, (^.))
 import Control.Monad.Except
 import Control.Monad.Reader
-import Data.Aeson hiding ((.=))
+import Data.Aeson hiding ((.=), decode)
 import Data.Map.Strict (Map)
 import Data.Maybe (fromMaybe)
 import Data.Monoid
@@ -36,10 +38,10 @@ import Gargantext.Prelude
 import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist)
 import System.IO (FilePath, hClose)
 import System.IO.Temp (withTempFile)
-import qualified Data.ByteString.Lazy as L
-import qualified Data.List as List
-import qualified Data.Map.Strict as Map
-import qualified Data.Map.Strict.Patch.Internal as Patch
+import qualified Data.ByteString.Lazy                   as DBL
+import qualified Data.List                              as List
+import qualified Data.Map.Strict                        as Map
+import qualified Data.Map.Strict.Patch.Internal         as Patch
 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
 
 ------------------------------------------------------------------------
@@ -84,7 +86,7 @@ mkNodeStorySaver nsd mvns = mkDebounce settings
   where
     settings = defaultDebounceSettings
                  { debounceAction = withMVar mvns (writeNodeStories nsd)
-                 , debounceFreq = 10 * minute
+                 , debounceFreq = 1 * minute
 --                 , debounceEdge = trailingEdge -- Trigger on the trailing edge
                  }
     minute = 60 * second
@@ -117,9 +119,16 @@ nodeStoryRead nsd ni = do
   let nsp = nodeStoryPath nsd ni
   exists <- doesFileExist nsp
   if exists
-     then deserialise <$> L.readFile nsp
+     then deserialise <$> DBL.readFile nsp
      else pure (initNodeStory ni)
 
+nodeStoryRead_test :: NodeStoryDir -> NodeId -> IO (Maybe [ TableNgrams.NgramsType ])
+nodeStoryRead_test nsd ni = nodeStoryRead nsd ni >>= \n -> pure
+                          $ fmap Map.keys
+                          $ fmap _a_state
+                          $ Map.lookup ni
+                          $ _unNodeStory n
+
 ------------------------------------------------------------------------
 type NodeStoryDir = FilePath
 
@@ -140,7 +149,7 @@ saverAction' :: NodeStoryDir -> NodeId -> Serialise a => a -> IO ()
 saverAction' repoDir nId a = do
   withTempFile repoDir ((cs $ show nId) <> "-tmp-repo.cbor") $ \fp h -> do
     printDebug "repoSaverAction" fp
-    L.hPut h $ serialise a
+    DBL.hPut h $ serialise a
     hClose h
     renameFile fp (nodeStoryPath repoDir nId)
 
@@ -150,7 +159,6 @@ nodeStoryPath repoDir nId = repoDir <> "/" <> filename
     filename = "repo" <> "-" <> (cs $ show nId) <> ".cbor"
 
 
-
 ------------------------------------------------------------------------
 -- TODO : repo Migration TODO TESTS
 repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
@@ -165,24 +173,34 @@ repoToNodeListStory (Repo _v s h) = NodeStory $ Map.fromList ns
                     -> (n, let hs = fromMaybe [] (Map.lookup n h') in
                                Archive (List.length hs) ns' hs
                        )
-                  ) s'
+                  ) $ Map.toList s'
 
 ngramsState_migration :: NgramsState
-                      -> [(NodeId,NgramsState')]
+                      -> Map NodeId NgramsState'
 ngramsState_migration ns =
-    [ (nid, Map.singleton nt table)
-    | (nt, nTable) <- Map.toList ns
-    , (nid, table) <- Map.toList nTable
-    ]
+  Map.fromListWith (Map.union) $ 
+  List.concat $
+    map (\(nt, nTable)
+          -> map (\(nid, table)
+                   -> (nid, Map.singleton nt table)
+                 ) $ Map.toList nTable
+        ) $ Map.toList ns
+
 
 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
-    ]
+                               $ List.concat
+                               $ map toPatch np'
+  where
+    toPatch :: NgramsStatePatch -> [(NodeId, [NgramsStatePatch'])]
+    toPatch p = 
+      List.concat $
+        map (\(nt, nTable)
+              -> map (\(nid, table)
+                       -> (nid, [fst $ Patch.singleton nt table])
+                     ) $ Patch.toList nTable
+            ) $ Patch.toList p
 
 ------------------------------------------------------------------------
 
@@ -230,7 +248,6 @@ instance (ToJSON s, ToJSON p) => ToJSON (Archive s p) where
   toEncoding = genericToEncoding $ unPrefix "_a_"
 
 ------------------------------------------------------------------------
-
 initNodeStory :: Monoid s => NodeId -> NodeStory s p
 initNodeStory ni = NodeStory $ Map.singleton ni initArchive
 
@@ -240,7 +257,7 @@ initArchive = Archive 0 mempty []
 initNodeListStoryMock :: NodeListStory
 initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
   where
-    nodeListId = 10
+    nodeListId = 0
     archive        = Archive 0 ngramsTableMap []
     ngramsTableMap = Map.singleton TableNgrams.NgramsTerms
                    $ Map.fromList
@@ -248,6 +265,9 @@ initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
                    | n <- mockTable ^. _NgramsTable
                    ]
 
+------------------------------------------------------------------------
+
+
 ------------------------------------------------------------------------
 -- | Lenses at the bottom of the file because Template Haskell would reorder order of execution in others cases
 makeLenses ''NodeStoryEnv