{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.API.Admin.Settings
where
-import Codec.Serialise (Serialise(), serialise)
+import Codec.Serialise (Serialise(), serialise, deserialise)
import Control.Concurrent
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Control.Exception (finally)
import Control.Lens
import Control.Monad.Logger
import Control.Monad.Reader
-import Data.Aeson hiding (encode)
import Data.ByteString (ByteString)
import Data.Either (either)
import Data.Maybe (fromMaybe)
import GHC.Generics (Generic)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..), r_version, saveRepo, initRepo, renv_var, renv_lock)
-import Gargantext.Database.Prelude (databaseParameters, HasConnectionPool(..), Cmd', runCmd)
+import Gargantext.Database.Prelude (databaseParameters, HasConnectionPool(..), Cmd', runCmd, HasConfig(..))
import Gargantext.Prelude
+
import Network.HTTP.Client (Manager)
import Network.HTTP.Client.TLS (newTlsManager)
import Prelude (Bounded(), fail)
import Web.HttpApiData (parseUrlPiece)
import qualified Data.ByteString.Lazy as L
import qualified Servant.Job.Core
-
+import Gargantext.Prelude.Config (GargConfig(), readConfig, defaultConfig)
type PortNumber = Int
, _cookieSettings :: CookieSettings
, _sendLoginEmails :: SendEmailType
, _scrapydUrl :: BaseUrl
- , _fileFolder :: FilePath
+ , _config :: GargConfig
}
makeLenses ''Settings
devSettings jwkFile = do
jwkExists <- doesFileExist jwkFile
when (not jwkExists) $ writeKey jwkFile
- jwk <- readKey jwkFile
+ jwk <- readKey jwkFile
pure $ Settings
{ _allowedOrigin = "http://localhost:8008"
, _allowedHost = "localhost:3000"
-- , _dbServer = "localhost"
, _sendLoginEmails = LogEmailToConsole
, _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
- , _fileFolder = "data"
, _cookieSettings = defaultCookieSettings { cookieXsrfSetting = Just xsrfCookieSetting } -- TODO-SECURITY tune
, _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
+ , _config = defaultConfig
}
where
xsrfCookieSetting = defaultXsrfCookieSettings { xsrfExcludeGet = True }
, _env_manager :: !Manager
, _env_self_url :: !BaseUrl
, _env_scrapers :: !ScrapersEnv
+ , _env_gargConfig :: !GargConfig
}
deriving (Generic)
makeLenses ''Env
+instance HasConfig Env where
+ hasConfig = env_gargConfig
+
instance HasConnectionPool Env where
connPool = env_pool
instance HasSettings Env where
settings = env_settings
-instance Servant.Job.Core.HasEnv Env (Job ScraperStatus ScraperStatus) where
+instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
_env = env_scrapers . Servant.Job.Core._env
-instance HasJobEnv Env ScraperStatus ScraperStatus where
+instance HasJobEnv Env JobLog JobLog where
job_env = env_scrapers
data MockEnv = MockEnv
repoDir = "repos"
repoSnapshot :: FilePath
-repoSnapshot = repoDir <> "/repo.json"
+repoSnapshot = repoDir <> "/repo.cbor"
-- | TODO add hard coded file in Settings
-- This assumes we own the lock on repoSnapshot.
repoSaverAction :: Serialise a => a -> IO ()
repoSaverAction a = do
- withTempFile "repos" "tmp-repo.json" $ \fp h -> do
- -- printDebug "repoSaverAction" fp
+ withTempFile "repos" "tmp-repo.cbor" $ \fp h -> do
+ printDebug "repoSaverAction" fp
L.hPut h $ serialise a
hClose h
renameFile fp repoSnapshot
mkRepoSaver repo_var = mkDebounce settings
where
settings = defaultDebounceSettings
- { debounceFreq = 1000000 -- 1 second
+ { debounceFreq = let n = 6 :: Int in 10^n -- 1 second
, debounceAction = withMVar repo_var repoSaverAction
-- Here this not only `readMVar` but `takeMVar`.
-- Namely while repoSaverAction is saving no other change
mvar <- newMVar =<<
if repoExists
then do
- e_repo <- eitherDecodeFileStrict repoSnapshot
- repo <- either fail pure e_repo
+ -- e_repo <- eitherDecodeStrict <$> deserialise <$> L.readFile repoSnapshot
+ repo <- deserialise <$> L.readFile repoSnapshot
+ -- repo <- either fail pure e_repo
let archive = repoSnapshot <> ".v" <> show (repo ^. r_version)
copyFile repoSnapshot archive
pure repo
newEnv :: PortNumber -> FilePath -> IO Env
newEnv port file = do
- manager <- newTlsManager
- settings <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
+ manager <- newTlsManager
+ settings <- devSettings devJwkFile <&> 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
- pool <- newPool param
- repo <- readRepoEnv
+ self_url <- parseBaseUrl $ "http://0.0.0.0:" <> show port
+ param <- databaseParameters file
+ pool <- newPool param
+ repo <- readRepoEnv
scrapers_env <- newJobEnv defaultSettings manager
- logger <- newStderrLoggerSet defaultBufSize
+ logger <- newStderrLoggerSet defaultBufSize
+ config <- readConfig file
pure $ Env
{ _env_settings = settings
, _env_manager = manager
, _env_scrapers = scrapers_env
, _env_self_url = self_url
+ , _env_gargConfig = config
}
newPool :: ConnectInfo -> IO (Pool Connection)
newPool param = createPool (connect param) close 1 (60*60) 8
data DevEnv = DevEnv
- { _dev_env_pool :: !(Pool Connection)
- , _dev_env_repo :: !RepoEnv
+ { _dev_env_pool :: !(Pool Connection)
+ , _dev_env_repo :: !RepoEnv
, _dev_env_settings :: !Settings
+ , _dev_env_config :: !GargConfig
}
makeLenses ''DevEnv
+instance HasConfig DevEnv where
+ hasConfig = dev_env_config
+
instance HasConnectionPool DevEnv where
connPool = dev_env_pool
pool <- newPool param
repo <- readRepoEnv
setts <- devSettings devJwkFile
+ config <- readConfig iniPath
pure $ DevEnv
{ _dev_env_pool = pool
, _dev_env_repo = repo
, _dev_env_settings = setts
+ , _dev_env_config = config
}
-- | 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