src/Gargantext/API/Admin/Settings.hs

   1 {-|
   2 Module      : Gargantext.API.Admin.Settings
   3 Description : Settings of the API (Server and Client)
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 TODO-SECURITY: Critical
  11 -}
  12
  13
  14
  15 {-# LANGUAGE ScopedTypeVariables #-}
  16 {-# LANGUAGE TemplateHaskell     #-}
  17
  18 module Gargantext.API.Admin.Settings
  19     where
  20
  21 -- import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
  22 import Codec.Serialise (Serialise(), serialise)
  23 import Control.Lens
  24 import Control.Monad.Logger (LogLevel(..))
  25 import Control.Monad.Reader
  26 import Data.Maybe (fromMaybe)
  27 import Data.Pool (Pool, createPool)
  28 import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
  29 import Gargantext.Core.NodeStory
  30 import Gargantext.Prelude.Config ({-GargConfig(..),-} {-gc_repofilepath,-} readConfig)
  31 import Network.HTTP.Client.TLS (newTlsManager)
  32 import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSettings(..), defaultCookieSettings, defaultXsrfCookieSettings, readKey, writeKey)
  33 import Servant.Client (parseBaseUrl)
  34 import Servant.Job.Async (newJobEnv, defaultSettings)
  35 import System.Directory
  36 -- import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
  37 import System.IO (FilePath, hClose)
  38 import System.IO.Temp (withTempFile)
  39 import System.Log.FastLogger
  40 import qualified Data.ByteString.Lazy as L
  41
  42
  43 import Gargantext.API.Admin.EnvTypes
  44 import Gargantext.API.Admin.Types
  45 -- import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
  46 import Gargantext.Core.NLP (nlpServerMap)
  47 import Gargantext.Database.Prelude (databaseParameters, hasConfig)
  48 import Gargantext.Prelude
  49 import Gargantext.Prelude.Config (gc_js_job_timeout, gc_js_id_timeout)
  50 import qualified Gargantext.Prelude.Mail as Mail
  51 import qualified Gargantext.Prelude.NLP as NLP
  52 import qualified Gargantext.Utils.Jobs       as Jobs
  53 import qualified Gargantext.Utils.Jobs.Monad as Jobs
  54 import qualified Gargantext.Utils.Jobs.Queue as Jobs
  55 import qualified Gargantext.Utils.Jobs.Settings as Jobs
  56
  57 devSettings :: FilePath -> IO Settings
  58 devSettings jwkFile = do
  59   jwkExists <- doesFileExist jwkFile
  60   when (not jwkExists) $ writeKey jwkFile
  61   jwk       <- readKey jwkFile
  62   pure $ Settings
  63     { _allowedOrigin = "http://localhost:8008"
  64     , _allowedHost = "localhost:3000"
  65     , _appPort = 3000
  66     , _logLevelLimit = LevelDebug
  67 --    , _dbServer = "localhost"
  68     , _sendLoginEmails = LogEmailToConsole
  69     , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
  70     , _cookieSettings = defaultCookieSettings { cookieXsrfSetting = Just xsrfCookieSetting } -- TODO-SECURITY tune
  71     , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
  72     }
  73   where
  74     xsrfCookieSetting = defaultXsrfCookieSettings { xsrfExcludeGet = True }
  75
  76 {- NOT USED YET
  77 import System.Environment (lookupEnv)
  78
  79 reqSetting :: FromHttpApiData a => Text -> IO a
  80 reqSetting name = do
  81     e <- fromMaybe (panic $ "Missing " <> name) <$> lookupEnv (unpack name)
  82     pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
  83
  84 optSetting :: FromHttpApiData a => Text -> a -> IO a
  85 optSetting name d = do
  86     me <- lookupEnv (unpack name)
  87     case me of
  88         Nothing -> pure d
  89         Just e -> pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
  90
  91 settingsFromEnvironment :: IO Settings
  92 settingsFromEnvironment =
  93     Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
  94              <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
  95              <*> optSetting "PORT" 3000
  96              <*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn")
  97              <*> reqSetting "DB_SERVER"
  98              <*> (parseJwk <$> reqSetting "JWT_SECRET")
  99              <*> optSetting "SEND_EMAIL" SendEmailViaAws
 100 -}
 101
 102 -----------------------------------------------------------------------
 103 -- | RepoDir FilePath configuration
 104 type RepoDirFilePath = FilePath
 105
 106 repoSnapshot :: RepoDirFilePath -> FilePath
 107 repoSnapshot repoDir = repoDir <> "/repo.cbor"
 108
 109
 110
 111 -- This assumes we own the lock on repoSnapshot.
 112 repoSaverAction :: RepoDirFilePath -> Serialise a => a -> IO ()
 113 repoSaverAction repoDir a = do
 114   withTempFile repoDir "tmp-repo.cbor" $ \fp h -> do
 115     -- printDebug "repoSaverAction" fp
 116     L.hPut h $ serialise a
 117     hClose h
 118     renameFile fp (repoSnapshot repoDir)
 119
 120
 121
 122 {-
 123 -- The use of mkDebounce makes sure that repoSaverAction is not called too often.
 124 -- If repoSaverAction start taking more time than the debounceFreq then it should
 125 -- be increased.
 126 mkRepoSaver :: RepoDirFilePath -> MVar NgramsRepo -> IO (IO ())
 127 mkRepoSaver repoDir repo_var = mkDebounce settings'
 128   where
 129     settings' = defaultDebounceSettings
 130                  { debounceFreq   = let n = 6 :: Int in 10^n  -- 1 second
 131                  , debounceAction = withMVar repo_var (repoSaverAction repoDir)
 132                    -- Here this not only `readMVar` but `takeMVar`.
 133                    -- Namely while repoSaverAction is saving no other change
 134                    -- can be made to the MVar.
 135                    -- This might be not efficent and thus reconsidered later.
 136                    -- However this enables to safely perform a *final* save.
 137                    -- See `cleanEnv`.
 138                    -- Future work:
 139                    -- Add a new MVar just for saving.
 140                  }
 141
 142 -}
 143 {-
 144 readRepoEnv :: FilePath -> IO RepoEnv
 145 readRepoEnv repoDir = do
 146   -- Does file exist ? :: Bool
 147   _repoDir <- createDirectoryIfMissing True repoDir
 148
 149   repoFile <- doesFileExist (repoSnapshot repoDir)
 150
 151   -- Is file not empty ? :: Bool
 152   repoExists <- if repoFile
 153              then (>0) <$> getFileSize (repoSnapshot repoDir)
 154              else pure False
 155
 156   mlock <- tryLockFile (repoSnapshot repoDir) Exclusive
 157   lock <- maybe (panic "Repo file already locked") pure mlock
 158
 159   mvar <- newMVar =<<
 160     if repoExists
 161       then do
 162         -- e_repo <- eitherDecodeStrict <$> deserialise <$> L.readFile repoSnapshot
 163         repo <- deserialise <$> L.readFile (repoSnapshot repoDir)
 164         -- repo   <- either fail pure e_repo
 165         let archive = (repoSnapshot repoDir) <> ".v" <> show (repo ^. r_version)
 166         copyFile (repoSnapshot repoDir) archive
 167         pure repo
 168       else
 169         pure initRepo
 170   -- TODO save in DB here
 171   saver <- mkRepoSaver repoDir mvar
 172   pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
 173 --}
 174
 175 devJwkFile :: FilePath
 176 devJwkFile = "dev.jwk"
 177
 178 newEnv :: PortNumber -> FilePath -> IO Env
 179 newEnv port file = do
 180   manager_env  <- newTlsManager
 181   settings'    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
 182   when (port /= settings' ^. appPort) $
 183     panic "TODO: conflicting settings of port"
 184
 185   config_env    <- readConfig file
 186   prios         <- Jobs.readPrios (file <> ".jobs")
 187   let prios' = Jobs.applyPrios prios Jobs.defaultPrios
 188   putStrLn $ "Overrides: " <> show prios
 189   putStrLn $ "New priorities: " <> show prios'
 190   self_url_env  <- parseBaseUrl $ "http://0.0.0.0:" <> show port
 191   dbParam       <- databaseParameters file
 192   pool          <- newPool dbParam
 193   --nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
 194   nodeStory_env <- readNodeStoryEnv pool
 195   scrapers_env  <- newJobEnv defaultSettings manager_env
 196
 197   secret        <- Jobs.genSecret
 198   let jobs_settings = (Jobs.defaultJobSettings 1 secret)
 199                         & Jobs.l_jsJobTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_job_timeout)
 200                         & Jobs.l_jsIDTimeout  .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_id_timeout)
 201   jobs_env      <- Jobs.newJobEnv jobs_settings prios' manager_env
 202   logger        <- newStderrLoggerSet defaultBufSize
 203   config_mail   <- Mail.readConfig file
 204   config_nlp    <- NLP.readConfig file
 205
 206   pure $ Env
 207     { _env_settings  = settings'
 208     , _env_logger    = logger
 209     , _env_pool      = pool
 210     , _env_nodeStory = nodeStory_env
 211     , _env_manager   = manager_env
 212     , _env_scrapers  = scrapers_env
 213     , _env_jobs      = jobs_env
 214     , _env_self_url  = self_url_env
 215     , _env_config    = config_env
 216     , _env_mail      = config_mail
 217     , _env_nlp       = nlpServerMap config_nlp
 218     }
 219
 220 newPool :: ConnectInfo -> IO (Pool Connection)
 221 newPool param = createPool (connect param) close 1 (60*60) 8
 222
 223 {-
 224 cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
 225 cleanEnv env = do
 226   r <- takeMVar (env ^. repoEnv . renv_var)
 227   repoSaverAction (env ^. hasConfig . gc_repofilepath) r
 228   unlockFile (env ^. repoEnv . renv_lock)
 229 --}