-{-|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
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)
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
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
, _jwtSecret = parseJwk "MVg0YAPVSPiYQc/qIs/rV/X32EFR0zOJWfHFgMbszMw="
, _sendLoginEmails = LogEmailToConsole
, _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
+ , _fileFolder = "data"
}
{ _env_settings :: !Settings
, _env_logger :: !LoggerSet
, _env_conn :: !Connection
+ , _env_repo :: !RepoEnv
, _env_manager :: !Manager
, _env_self_url :: !BaseUrl
, _env_scrapers :: !ScrapersEnv
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
}
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