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