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