[NGRAMS-REPO] Rework the way one saves repo.json (in particular this fixes gargantext-import)

bin/gargantext-import/Main.hs

@@ -31,7 +31,7 @@ import Gargantext.Database.Schema.User (insertUsersDemo)
 import Gargantext.Text.Terms (TermType(..))
 import Gargantext.Core (Lang(..))
 import Gargantext.API.Node () -- instances
-import Gargantext.API.Settings (newDevEnvWith, runCmdDev, DevEnv)
+import Gargantext.API.Settings (withDevEnv, runCmdDev, DevEnv)
 import System.Environment (getArgs)
 import Gargantext.Text.Parsers.GrandDebat (readFile, GrandDebatReference(..))
 import qualified Data.Text as Text
@@ -58,19 +58,17 @@ main = do
         flowCorpus (Text.pack user) (Text.pack name) (Multi FR) docs
 
 
-  env <- newDevEnvWith iniPath
-  -- Better if we keep only one call to runCmdDev.
-  _ <- if userCreate == "true"
-        then runCmdDev env createUsers
-        else pure 0 --(cs "false")
-  
-  _ <- runCmdDev env debatCorpus
-  {-
-  _ <- if corpusType == "csv"
-          then runCmdDev env csvCorpus
-          else if corpusType == "debat"
-            then runCmdDev env debatCorpus
-            else panic "corpusType unknown: try \"csv\" or \"debat\""
-  -}
-  pure ()
+  withDevEnv iniPath $ \env -> do
+    _ <- if userCreate == "true"
+          then runCmdDev env createUsers
+          else pure 0 --(cs "false")
 
+    _ <- runCmdDev env debatCorpus
+    {-
+    _ <- if corpusType == "csv"
+            then runCmdDev env csvCorpus
+            else if corpusType == "debat"
+              then runCmdDev env debatCorpus
+              else panic "corpusType unknown: try \"csv\" or \"debat\""
+    -}
+    pure ()

package.yaml

@@ -81,6 +81,7 @@ library:
   - aeson-pretty
   - async
   - attoparsec
+  - auto-update
   - base >=4.7 && <5
   - base16-bytestring
   - blaze-html
@@ -167,7 +168,6 @@ library:
   - text-metrics
   - time
   - time-locale-compat
-  - time-units
   - timezone-series
   - transformers
   - transformers-base

src/Control/Debounce.hs

-{- This file is part of json-state.
- - Imported in haskell-gargantext.
- -
- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
- -
- - ♡ Copying is an act of love. Please copy, reuse and share.
- -
- - The author(s) have dedicated all copyright and related and neighboring
- - rights to this software to the public domain worldwide. This software is
- - distributed without any warranty.
- -
- - You should have received a copy of the CC0 Public Domain Dedication along
- - with this software. If not, see
- - <http://creativecommons.org/publicdomain/zero/1.0/>.
- -}
-
--- | This is similar to the same module from "auto-update" package, except here
--- the caller can pass a parameter to the debounced action. Also, the returned
--- action comes in 2 versions.
---
--- The first is non-blocking at the cost of a small chance a parameter isn't
--- passed and is instead discarded. This can happen if the action is called
--- from different threads simultanously. One empties the 'MVar', and the other
--- happens to fill it first, and then the parameter the former thread passed is
--- discarded. If you run the action from a single thread, there is no problem,
--- or if missing at a hopefully small chance isn't a problem.
---
--- The second is blocking, but only in the small chance described above.
--- Otherwise it doesn't block in practice.
---
--- Also, exceptions aren't handled. This includes async exceptions and any
--- exceptions thrown by the given action.
-module Control.Debounce
-    ( mkDebounce
-    )
-where
-
-import Control.Monad (forever, void)
-import Control.Concurrent (forkIO, threadDelay)
-import Control.Concurrent.MVar
-import Data.Time.Units
-
-mkDebounce :: TimeUnit t
-           => t               -- ^ Time delay between calls to the action
-           -> (a -> IO ())    -- ^ Action to perform
-           -> IO ( a -> IO () --   Never-blocking version
-                 , a -> IO () --   Possibly-blocking version
-                 )
-mkDebounce interval action = do
-    paramVar <- newEmptyMVar
-    let run = void $ forkIO $ forever $ do
-            param <- takeMVar paramVar
-            action param
-            threadDelay $ fromInteger $ toMicroseconds interval
-        actNB param = do
-            void $ tryTakeMVar paramVar
-            void $ tryPutMVar paramVar param
-        actPB param = do
-            void $ tryTakeMVar paramVar
-            putMVar paramVar param
-    run
-    return (actNB, actPB)

src/Gargantext/API/Ngrams.hs

@@ -816,7 +816,9 @@ addListNgrams listId ngramsType nes = do
 putListNgrams :: RepoCmdM env err m
               => NodeId -> NgramsType
               -> [NgramsElement] -> m ()
+putListNgrams _ _ [] = pure ()
 putListNgrams listId ngramsType nes = do
+  -- printDebug "putListNgrams" (length nes)
   var <- view repoVar
   liftIO $ modifyMVar_ var $
     pure . (r_state . at ngramsType %~ (Just . (at listId %~ (Just . (m <>) . something)) . something))

src/Gargantext/API/Settings.hs

@@ -41,7 +41,6 @@ import Data.Maybe (fromMaybe)
 import Data.Either (either)
 import Data.Text
 import Data.Text.Encoding (encodeUtf8)
-import Data.Time.Units
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as L
 
@@ -53,14 +52,14 @@ import qualified Jose.Jwk as Jose
 import qualified Jose.Jwa as Jose
 
 import Control.Concurrent
-import Control.Debounce (mkDebounce)
-import Control.Exception (SomeException, finally, handle)
+import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
+import Control.Exception (finally)
 import Control.Monad.Logger
 import Control.Monad.Reader
 import Control.Lens
 import Gargantext.Prelude
 import Gargantext.Database.Utils (databaseParameters, HasConnection(..), Cmd', runCmd)
-import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..), r_version, saveRepo, initRepo, renv_lock)
+import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..), r_version, saveRepo, initRepo, renv_var, renv_lock)
 import Gargantext.API.Orchestrator.Types
 
 type PortNumber = Int
@@ -171,21 +170,30 @@ makeLenses ''MockEnv
 repoSnapshot :: FilePath
 repoSnapshot = "repo.json"
 
-ignoreExc :: IO () -> IO ()
-ignoreExc = handle $ \(_ :: SomeException) -> return ()
-
+-- This assumes we own the lock on repoSnapshot.
 repoSaverAction :: ToJSON a => a -> IO ()
-repoSaverAction a = ignoreExc $ do
-  -- TODO file locking
+repoSaverAction a = do
   withTempFile "." "tmp-repo.json" $ \fp h -> do
+    -- printDebug "repoSaverAction" fp
     L.hPut h $ encode a
     hClose h
     renameFile fp repoSnapshot
 
 mkRepoSaver :: MVar NgramsRepo -> IO (IO ())
-mkRepoSaver repo_var = do
-  (saveAction, _) <- mkDebounce (10 :: Second) repoSaverAction
-  pure $ readMVar repo_var >>= saveAction
+mkRepoSaver repo_var = mkDebounce settings
+  where
+    settings = defaultDebounceSettings
+                 { debounceFreq   = 1000000 -- 1 second
+                 , debounceAction = withMVar repo_var repoSaverAction
+                   -- ^ Here this not only `readMVar` but `takeMVar`.
+                   -- Namely while repoSaverAction is saving no other change
+                   -- can be made to the MVar.
+                   -- This might be not efficent and thus reconsidered later.
+                   -- However this enables to safely perform a *final* save.
+                   -- See `cleanEnv`.
+                   -- Future work:
+                   -- * Add a new MVar just for saving.
+                 }
 
 readRepoEnv :: IO RepoEnv
 readRepoEnv = do
@@ -257,31 +265,34 @@ instance HasRepoSaver DevEnv where
 instance HasRepo DevEnv where
   repoEnv = dev_env_repo
 
-newDevEnvWith :: FilePath -> IO DevEnv
-newDevEnvWith file = do
-  param <- databaseParameters file
-  conn  <- connect param
-  repo  <- readRepoEnv
-  pure $ DevEnv
-    { _dev_env_conn = conn
-    , _dev_env_repo = repo
-    }
+cleanEnv :: HasRepo env => env -> IO ()
+cleanEnv env = do
+  r <- takeMVar (env ^. repoEnv . renv_var)
+  repoSaverAction r
+  unlockFile (env ^. repoEnv . renv_lock)
 
-withDevEnv :: (DevEnv -> IO a) -> IO a
-withDevEnv k = do
+withDevEnv :: FilePath -> (DevEnv -> IO a) -> IO a
+withDevEnv iniPath k = do
   env <- newDevEnv
-  k env `finally` unlockFile (env ^. repoEnv . renv_lock)
+  k env `finally` cleanEnv env
+
+  where
+    newDevEnv = do
+      param <- databaseParameters iniPath
+      conn  <- connect param
+      repo  <- readRepoEnv
+      pure $ DevEnv
+        { _dev_env_conn = conn
+        , _dev_env_repo = repo
+        }
 
 -- | Run Cmd Sugar for the Repl (GHCI)
 runCmdRepl :: Show err => Cmd' DevEnv err a -> IO a
-runCmdRepl f = withDevEnv $ \env -> runCmdDev env f
+runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
 
 runCmdReplServantErr :: Cmd' DevEnv ServantErr a -> IO a
 runCmdReplServantErr = runCmdRepl
 
-newDevEnv :: IO DevEnv
-newDevEnv = newDevEnvWith "gargantext.ini"
-
 -- Use only for dev
 -- In particular this writes the repo file after running
 -- the command.