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