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.Core.Types (NodeId)
  35 import Gargantext.Database.Prelude (databaseParameters, HasConfig(..))
  36 import Gargantext.Prelude
  37 import Gargantext.Prelude.Config (GargConfig(..), gc_repofilepath, readConfig)
  38 import Network.HTTP.Client.TLS (newTlsManager)
  39 import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSettings(..), defaultCookieSettings, defaultXsrfCookieSettings, readKey, writeKey)
  40 import Servant.Client (parseBaseUrl)
  41 import Servant.Job.Async (newJobEnv, defaultSettings)
  42 import System.Directory
  43 import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
  44 import System.IO (FilePath, hClose)
  45 import System.IO.Temp (withTempFile)
  46 import System.Log.FastLogger
  47 import qualified Data.ByteString.Lazy as L
  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
 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 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   scrapers_env <- newJobEnv defaultSettings manager_env
 183   logger       <- newStderrLoggerSet defaultBufSize
 184
 185   pure $ Env
 186     { _env_settings = settings'
 187     , _env_logger   = logger
 188     , _env_pool     = pool
 189     , _env_repo     = repo
 190     , _env_manager  = manager_env
 191     , _env_scrapers = scrapers_env
 192     , _env_self_url = self_url_env
 193     , _env_config   = config_env
 194     }
 195
 196 newPool :: ConnectInfo -> IO (Pool Connection)
 197 newPool param = createPool (connect param) close 1 (60*60) 8
 198
 199 cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
 200 cleanEnv env = do
 201   r <- takeMVar (env ^. repoEnv . renv_var)
 202   repoSaverAction (env ^. hasConfig . gc_repofilepath) r
 203   unlockFile (env ^. repoEnv . renv_lock)
 204