[NGRAMS-REPO] Use debounce directly instead of json-state

package.yaml

@@ -111,7 +111,6 @@ library:
   - ini
   - insert-ordered-containers
   - jose-jwt
-  - json-state
     #  - kmeans-vector
   - KMP
   - lens
@@ -159,6 +158,7 @@ library:
   - string-conversions
   - swagger2
   - tagsoup
+  - temporary
   - text-metrics
   - time
   - time-locale-compat

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/Settings.hs

@@ -30,7 +30,8 @@ import GHC.Enum
 import GHC.Generics (Generic)
 import Prelude (Bounded(), fail)
 import System.Environment (lookupEnv)
-import System.IO (FilePath)
+import System.IO (FilePath, hClose)
+import System.IO.Temp (withTempFile)
 import Database.PostgreSQL.Simple (Connection, connect)
 import Network.HTTP.Client (Manager)
 import Network.HTTP.Client.TLS (newTlsManager)
@@ -38,11 +39,11 @@ 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 Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as L
 
 import Servant
 import Servant.Client (BaseUrl, parseBaseUrl)
@@ -52,7 +53,8 @@ import qualified Jose.Jwk as Jose
 import qualified Jose.Jwa as Jose
 
 import Control.Concurrent
-import Control.Exception (finally)
+import Control.Debounce (mkDebounce)
+import Control.Exception (SomeException, finally, handle)
 import Control.Monad.Logger
 import Control.Monad.Reader
 import Control.Lens
@@ -188,9 +190,20 @@ readRepo = do
       else
         pure initRepo
 
+ignoreExc :: IO () -> IO ()
+ignoreExc = handle $ \(_ :: SomeException) -> return ()
+
+repoSaverAction :: ToJSON a => a -> IO ()
+repoSaverAction a = ignoreExc $ do
+  -- TODO file locking
+  withTempFile "." "tmp-repo.json" $ \fp h -> do
+    L.hPut h $ encode a
+    hClose h
+    renameFile fp repoSnapshot
+
 mkRepoSaver :: MVar NgramsRepo -> IO (IO ())
 mkRepoSaver repo_var = do
-  saveAction <- mkSaveState (10 :: Second) repoSnapshot
+  (saveAction, _) <- mkDebounce (10 :: Second) repoSaverAction
   pure $ readMVar repo_var >>= saveAction
 
 newEnv :: PortNumber -> FilePath -> IO Env