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.API.Admin.EnvTypes
  31 import Gargantext.API.Admin.Types
  32 import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
  33 import Gargantext.Core.NodeStory
  34 import Gargantext.Database.Prelude (databaseParameters, HasConfig(..))
  35 import Gargantext.Prelude
  36 import Gargantext.Prelude.Config (GargConfig(..), gc_repofilepath, readConfig)
  37 import Network.HTTP.Client.TLS (newTlsManager)
  38 import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSettings(..), defaultCookieSettings, defaultXsrfCookieSettings, readKey, writeKey)
  39 import Servant.Client (parseBaseUrl)
  40 import Servant.Job.Async (newJobEnv, defaultSettings)
  41 import System.Directory
  42 import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
  43 import System.IO (FilePath, hClose)
  44 import System.IO.Temp (withTempFile)
  45 import System.Log.FastLogger
  46 import qualified Data.ByteString.Lazy as L
  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
 101
 102 -- This assumes we own the lock on repoSnapshot.
 103 repoSaverAction :: RepoDirFilePath -> Serialise a => a -> IO ()
 104 repoSaverAction repoDir a = do
 105   withTempFile repoDir "tmp-repo.cbor" $ \fp h -> do
 106     printDebug "repoSaverAction" fp
 107     L.hPut h $ serialise a
 108     hClose h
 109     renameFile fp (repoSnapshot repoDir)
 110
 111
 112
 113 -- The use of mkDebounce makes sure that repoSaverAction is not called too often.
 114 -- If repoSaverAction start taking more time than the debounceFreq then it should
 115 -- be increased.
 116 mkRepoSaver :: RepoDirFilePath -> MVar NgramsRepo -> IO (IO ())
 117 mkRepoSaver repoDir repo_var = mkDebounce settings'
 118   where
 119     settings' = defaultDebounceSettings
 120                  { debounceFreq   = let n = 6 :: Int in 10^n  -- 1 second
 121                  , debounceAction = withMVar repo_var (repoSaverAction repoDir)
 122                    -- Here this not only `readMVar` but `takeMVar`.
 123                    -- Namely while repoSaverAction is saving no other change
 124                    -- can be made to the MVar.
 125                    -- This might be not efficent and thus reconsidered later.
 126                    -- However this enables to safely perform a *final* save.
 127                    -- See `cleanEnv`.
 128                    -- Future work:
 129                    -- Add a new MVar just for saving.
 130                  }
 131
 132 readRepoEnv :: FilePath -> IO RepoEnv
 133 readRepoEnv repoDir = do
 134   -- Does file exist ? :: Bool
 135   _repoDir <- createDirectoryIfMissing True repoDir
 136
 137   repoFile <- doesFileExist (repoSnapshot repoDir)
 138
 139   -- Is file not empty ? :: Bool
 140   repoExists <- if repoFile
 141              then (>0) <$> getFileSize (repoSnapshot repoDir)
 142              else pure False
 143
 144   mlock <- tryLockFile (repoSnapshot repoDir) Exclusive
 145   lock <- maybe (panic "Repo file already locked") pure mlock
 146
 147   mvar <- newMVar =<<
 148     if repoExists
 149       then do
 150         -- e_repo <- eitherDecodeStrict <$> deserialise <$> L.readFile repoSnapshot
 151         repo <- deserialise <$> L.readFile (repoSnapshot repoDir)
 152         -- repo   <- either fail pure e_repo
 153         let archive = (repoSnapshot repoDir) <> ".v" <> show (repo ^. r_version)
 154         copyFile (repoSnapshot repoDir) archive
 155         pure repo
 156       else
 157         pure initRepo
 158   -- TODO save in DB here
 159   saver <- mkRepoSaver repoDir mvar
 160   pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
 161
 162 devJwkFile :: FilePath
 163 devJwkFile = "dev.jwk"
 164
 165 newEnv :: PortNumber -> FilePath -> IO Env
 166 newEnv port file = do
 167   manager_env  <- newTlsManager
 168   settings'    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
 169   when (port /= settings' ^. appPort) $
 170     panic "TODO: conflicting settings of port"
 171
 172   config_env    <- readConfig file
 173   self_url_env  <- parseBaseUrl $ "http://0.0.0.0:" <> show port
 174   dbParam       <- databaseParameters file
 175   pool          <- newPool dbParam
 176   repo          <- readRepoEnv (_gc_repofilepath config_env)
 177   nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
 178   scrapers_env  <- newJobEnv defaultSettings manager_env
 179   logger        <- newStderrLoggerSet defaultBufSize
 180
 181   pure $ Env
 182     { _env_settings  = settings'
 183     , _env_logger    = logger
 184     , _env_pool      = pool
 185     , _env_repo      = repo
 186     , _env_nodeStory = nodeStory_env
 187     , _env_manager   = manager_env
 188     , _env_scrapers  = scrapers_env
 189     , _env_self_url  = self_url_env
 190     , _env_config    = config_env
 191     }
 192
 193 newPool :: ConnectInfo -> IO (Pool Connection)
 194 newPool param = createPool (connect param) close 1 (60*60) 8
 195
 196 cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
 197 cleanEnv env = do
 198   r <- takeMVar (env ^. repoEnv . renv_var)
 199   repoSaverAction (env ^. hasConfig . gc_repofilepath) r
 200   unlockFile (env ^. repoEnv . renv_lock)
 201