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