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