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