ElEve: alternative split
[gargantext.git] / src / Gargantext / API / Settings.hs
index bd71835949297af27a5dc9428f2b72fd174aaad6..8c47f08fc090727175e7e13cb94c60b42a26fa66 100644 (file)
@@ -1,13 +1,4 @@
-{-|PI/Application.hs
-API/Count.hs
-API/FrontEnd.hs
-API/Node.hs
-API/Auth.hs
-API.hs
-Database/NodeNodeNgram.hs
-Database/User.hs
-Database/Queries.hs
-
+{-| 
 Module      : Gargantext.API.Settings
 Description : Settings of the API (Server and Client)
 Copyright   : (c) CNRS, 2017-Present
@@ -17,35 +8,41 @@ Stability   : experimental
 Portability : POSIX
 -}
 
-
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
-{-# LANGUAGE NoImplicitPrelude           #-}
-{-# LANGUAGE DataKinds                   #-}
-{-# LANGUAGE DeriveGeneric               #-}
-{-# LANGUAGE ScopedTypeVariables         #-}
-{-# LANGUAGE TemplateHaskell             #-}
-{-# LANGUAGE OverloadedStrings           #-}
-{-# LANGUAGE FlexibleInstances           #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
 
 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 System.IO (FilePath, hClose)
+import System.IO.Temp (withTempFile)
+import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
 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.Text
 import Data.Text.Encoding (encodeUtf8)
-import Data.ByteString.Lazy.Internal
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as L
 
 import Servant
 import Servant.Client (BaseUrl, parseBaseUrl)
@@ -54,10 +51,15 @@ import Web.HttpApiData (parseUrlPiece)
 import qualified Jose.Jwk as Jose
 import qualified Jose.Jwa as Jose
 
+import Control.Concurrent
+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)
+import Gargantext.Database.Utils (databaseParameters, HasConnection(..), Cmd', runCmd)
+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
@@ -69,19 +71,23 @@ data SendEmailType = SendEmailViaAws
 
 
 data Settings = Settings
-    { _allowedOrigin   :: ByteString -- ^ allowed origin for CORS
-    , _allowedHost     :: ByteString   -- allowed host for CORS
+    { _allowedOrigin   :: ByteString   -- allowed origin for CORS
+    , _allowedHost     :: ByteString   -- allowed host for CORS
     , _appPort         :: PortNumber
-    , _logLevelLimit   :: LogLevel -- log level from the monad-logger package
+    , _logLevelLimit   :: LogLevel -- log level from the monad-logger package
 --    , _dbServer        :: Text
 --    ^ this is not used yet
-    , _jwtSecret       :: Jose.Jwk -- key from the jose-jwt package
+    , _jwtSecret       :: Jose.Jwk -- key from the jose-jwt package
     , _sendLoginEmails :: SendEmailType
     , _scrapydUrl      :: BaseUrl
+    , _fileFolder      :: FilePath
     }
 
 makeLenses ''Settings
 
+class HasSettings env where
+  settings :: Getter env Settings
+
 
 parseJwk :: Text -> Jose.Jwk
 parseJwk secretStr = jwk
@@ -105,6 +111,7 @@ devSettings = Settings
     , _jwtSecret = parseJwk "MVg0YAPVSPiYQc/qIs/rV/X32EFR0zOJWfHFgMbszMw="
     , _sendLoginEmails = LogEmailToConsole
     , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
+    , _fileFolder = "data"
     }
 
 
@@ -137,6 +144,7 @@ data Env = Env
   { _env_settings :: !Settings
   , _env_logger   :: !LoggerSet
   , _env_conn     :: !Connection
+  , _env_repo     :: !RepoEnv
   , _env_manager  :: !Manager
   , _env_self_url :: !BaseUrl
   , _env_scrapers :: !ScrapersEnv
@@ -145,6 +153,21 @@ data Env = Env
 
 makeLenses ''Env
 
+instance HasConnection Env where
+  connection = env_conn
+
+instance HasRepoVar Env where
+  repoVar = repoEnv . repoVar
+
+instance HasRepoSaver Env where
+  repoSaver = repoEnv . repoSaver
+
+instance HasRepo Env where
+  repoEnv = env_repo
+
+instance HasSettings Env where
+  settings = env_settings
+
 data MockEnv = MockEnv
   { _menv_firewall :: !FireWall
   }
@@ -152,22 +175,154 @@ data MockEnv = MockEnv
 
 makeLenses ''MockEnv
 
+-- | TODO add this path in Settings
+repoSnapshot :: FilePath
+repoSnapshot = "repo.json"
+
+-- | TODO add hard coded file in Settings
+-- This assumes we own the lock on repoSnapshot.
+repoSaverAction :: ToJSON a => a -> IO ()
+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 = 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
+  -- Does file exist ? :: Bool
+  repoFile <- doesFileExist repoSnapshot
+
+  -- Is file not empty ? :: Bool
+  repoExists <- if repoFile
+             then (>0) <$> getFileSize repoSnapshot
+             else pure False
+
+  mlock <- tryLockFile repoSnapshot Exclusive
+  lock <- maybe (panic "Repo file already locked") pure mlock
+
+  mvar <- 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 initRepo
+
+  saver <- mkRepoSaver mvar
+  pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
+
 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     <- readRepoEnv
   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       = repo
+    , _env_manager    = manager
+    , _env_scrapers   = scrapers_env
+    , _env_self_url   = self_url
     }
+
+data DevEnv = DevEnv
+  { _dev_env_conn :: !Connection
+  , _dev_env_repo :: !RepoEnv
+  , _dev_env_settings :: !Settings
+  }
+
+makeLenses ''DevEnv
+
+instance HasConnection DevEnv where
+  connection = dev_env_conn
+
+instance HasRepoVar DevEnv where
+  repoVar = repoEnv . repoVar
+
+instance HasRepoSaver DevEnv where
+  repoSaver = repoEnv . repoSaver
+
+instance HasRepo DevEnv where
+  repoEnv = dev_env_repo
+
+instance HasSettings DevEnv where
+  settings = dev_env_settings
+
+cleanEnv :: HasRepo env => env -> IO ()
+cleanEnv env = do
+  r <- takeMVar (env ^. repoEnv . renv_var)
+  repoSaverAction r
+  unlockFile (env ^. repoEnv . renv_lock)
+
+withDevEnv :: FilePath -> (DevEnv -> IO a) -> IO a
+withDevEnv iniPath k = do
+  env <- newDevEnv
+  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
+        , _dev_env_settings = devSettings
+        }
+
+-- | Run Cmd Sugar for the Repl (GHCI)
+runCmdRepl :: Show err => Cmd' DevEnv err a -> IO a
+runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
+
+runCmdReplServantErr :: Cmd' DevEnv ServantErr a -> IO a
+runCmdReplServantErr = runCmdRepl
+
+-- 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