{-| Module : Gargantext.API.Admin.Settings Description : Settings of the API (Server and Client) Copyright : (c) CNRS, 2017-Present License : AGPL + CECILL v3 Maintainer : team@gargantext.org Stability : experimental Portability : POSIX TODO-SECURITY: Critical -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Gargantext.API.Admin.Settings where -- import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction) import Codec.Serialise (Serialise(), serialise) import Control.Lens import Control.Monad.Logger (LogLevel(..)) import Control.Monad.Reader import Data.Maybe (fromMaybe) import Data.Pool (Pool, createPool) import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo) import Gargantext.Core.NodeStory 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.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.Core.NLP (nlpServerMap) import Gargantext.Database.Prelude (databaseParameters, hasConfig) import Gargantext.Prelude import Gargantext.Prelude.Config (gc_js_job_timeout, gc_js_id_timeout) import qualified Gargantext.Prelude.Mail as Mail import qualified Gargantext.Prelude.NLP as NLP import qualified Gargantext.Utils.Jobs as Jobs import qualified Gargantext.Utils.Jobs.Monad as Jobs import qualified Gargantext.Utils.Jobs.Queue as Jobs import qualified Gargantext.Utils.Jobs.Settings as Jobs devSettings :: FilePath -> IO Settings devSettings jwkFile = do jwkExists <- doesFileExist jwkFile when (not jwkExists) $ writeKey jwkFile jwk <- readKey jwkFile pure $ Settings { _allowedOrigin = "http://localhost:8008" , _allowedHost = "localhost:3000" , _appPort = 3000 , _logLevelLimit = LevelDebug -- , _dbServer = "localhost" , _sendLoginEmails = LogEmailToConsole , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800" , _cookieSettings = defaultCookieSettings { cookieXsrfSetting = Just xsrfCookieSetting } -- TODO-SECURITY tune , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune } where xsrfCookieSetting = defaultXsrfCookieSettings { xsrfExcludeGet = True } {- NOT USED YET import System.Environment (lookupEnv) reqSetting :: FromHttpApiData a => Text -> IO a reqSetting name = do e <- fromMaybe (panic $ "Missing " <> name) <$> lookupEnv (unpack name) pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e optSetting :: FromHttpApiData a => Text -> a -> IO a optSetting name d = do me <- lookupEnv (unpack name) case me of Nothing -> pure d Just e -> pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e settingsFromEnvironment :: IO Settings settingsFromEnvironment = Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN") <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST") <*> optSetting "PORT" 3000 <*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn") <*> reqSetting "DB_SERVER" <*> (parseJwk <$> reqSetting "JWT_SECRET") <*> optSetting "SEND_EMAIL" SendEmailViaAws -} ----------------------------------------------------------------------- -- | RepoDir FilePath configuration type RepoDirFilePath = FilePath repoSnapshot :: RepoDirFilePath -> FilePath repoSnapshot repoDir = repoDir <> "/repo.cbor" -- This assumes we own the lock on repoSnapshot. repoSaverAction :: RepoDirFilePath -> Serialise a => a -> IO () repoSaverAction repoDir a = do withTempFile repoDir "tmp-repo.cbor" $ \fp h -> do -- printDebug "repoSaverAction" fp L.hPut h $ serialise a hClose h renameFile fp (repoSnapshot repoDir) {- -- 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. mkRepoSaver :: RepoDirFilePath -> MVar NgramsRepo -> IO (IO ()) mkRepoSaver repoDir repo_var = mkDebounce settings' where settings' = defaultDebounceSettings { debounceFreq = let n = 6 :: Int in 10^n -- 1 second , debounceAction = withMVar repo_var (repoSaverAction repoDir) -- 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 :: FilePath -> IO RepoEnv readRepoEnv repoDir = do -- Does file exist ? :: Bool _repoDir <- createDirectoryIfMissing True repoDir repoFile <- doesFileExist (repoSnapshot repoDir) -- Is file not empty ? :: Bool repoExists <- if repoFile then (>0) <$> getFileSize (repoSnapshot repoDir) else pure False mlock <- tryLockFile (repoSnapshot repoDir) Exclusive lock <- maybe (panic "Repo file already locked") pure mlock mvar <- newMVar =<< if repoExists then do -- e_repo <- eitherDecodeStrict <$> deserialise <$> L.readFile repoSnapshot repo <- deserialise <$> L.readFile (repoSnapshot repoDir) -- repo <- either fail pure e_repo let archive = (repoSnapshot repoDir) <> ".v" <> show (repo ^. r_version) copyFile (repoSnapshot repoDir) archive pure repo else pure initRepo -- 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" newEnv :: PortNumber -> FilePath -> IO Env newEnv port file = do !manager_env <- newTlsManager !settings' <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file' when (port /= settings' ^. appPort) $ panic "TODO: conflicting settings of port" !config_env <- readConfig file prios <- Jobs.readPrios (file <> ".jobs") let prios' = Jobs.applyPrios prios Jobs.defaultPrios putStrLn $ "Overrides: " <> show prios putStrLn $ "New priorities: " <> show prios' !self_url_env <- parseBaseUrl $ "http://0.0.0.0:" <> show port dbParam <- databaseParameters file !pool <- newPool dbParam --nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env) !nodeStory_env <- readNodeStoryEnv pool !scrapers_env <- newJobEnv defaultSettings manager_env secret <- Jobs.genSecret let jobs_settings = (Jobs.defaultJobSettings 1 secret) & Jobs.l_jsJobTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_job_timeout) & Jobs.l_jsIDTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_id_timeout) !jobs_env <- Jobs.newJobEnv jobs_settings prios' manager_env !logger <- newStderrLoggerSet defaultBufSize !config_mail <- Mail.readConfig file !nlp_env <- nlpServerMap <$> NLP.readConfig file -- | An 'Env' by default doesn't have strict fields, but when constructing one in production -- we want to force them to WHNF to avoid accumulating unnecessary thunks. pure $ Env { _env_settings = settings' , _env_logger = logger , _env_pool = pool , _env_nodeStory = nodeStory_env , _env_manager = manager_env , _env_scrapers = scrapers_env , _env_jobs = jobs_env , _env_self_url = self_url_env , _env_config = config_env , _env_mail = config_mail , _env_nlp = nlp_env } 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) --}