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