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 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  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.Exception (finally)
  25 import Control.Lens
  26 import Control.Monad.Logger
  27 import Control.Monad.Reader
  28 import Data.Maybe (fromMaybe)
  29 import Data.Pool (Pool, createPool)
  30 import Data.Text
  31 import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
  32 import Network.HTTP.Client.TLS (newTlsManager)
  33 import Servant
  34 import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSettings(..), defaultCookieSettings, defaultXsrfCookieSettings, readKey, writeKey)
  35 import Servant.Client (parseBaseUrl)
  36 import Servant.Job.Async (newJobEnv, defaultSettings)
  37 import System.Directory
  38 import System.Environment (lookupEnv)
  39 import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
  40 import System.IO (FilePath, hClose)
  41 import System.IO.Temp (withTempFile)
  42 import System.Log.FastLogger
  43 import qualified Data.ByteString.Lazy as L
  44
  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.API.Ngrams (saveRepo)
  48 import Gargantext.Database.Prelude (databaseParameters, Cmd', runCmd, HasConfig(..))
  49 import Gargantext.Prelude
  50 import Gargantext.Prelude.Config (GargConfig(..), gc_repofilepath, readConfig, defaultConfig)
  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     , _config      = defaultConfig
  68     }
  69   where
  70     xsrfCookieSetting = defaultXsrfCookieSettings { xsrfExcludeGet = True }
  71
  72
  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 -- | RepoDir FilePath configuration
  98 type RepoDirFilePath = FilePath
  99
 100 repoSnapshot :: RepoDirFilePath -> FilePath
 101 repoSnapshot repoDir = repoDir <> "/repo.cbor"
 102
 103 -- | TODO add hard coded file in Settings
 104 -- This assumes we own the lock on repoSnapshot.
 105 repoSaverAction :: RepoDirFilePath -> Serialise a => a -> IO ()
 106 repoSaverAction repoDir a = do
 107   withTempFile "repos" "tmp-repo.cbor" $ \fp h -> do
 108     printDebug "repoSaverAction" fp
 109     L.hPut h $ serialise a
 110     hClose h
 111     renameFile fp (repoSnapshot repoDir)
 112
 113 mkRepoSaver :: RepoDirFilePath -> MVar NgramsRepo -> IO (IO ())
 114 mkRepoSaver repoDir repo_var = mkDebounce settings
 115   where
 116     settings = defaultDebounceSettings
 117                  { debounceFreq   = let n = 6 :: Int in 10^n  -- 1 second
 118                  , debounceAction = withMVar repo_var (repoSaverAction repoDir)
 119                    -- Here this not only `readMVar` but `takeMVar`.
 120                    -- Namely while repoSaverAction is saving no other change
 121                    -- can be made to the MVar.
 122                    -- This might be not efficent and thus reconsidered later.
 123                    -- However this enables to safely perform a *final* save.
 124                    -- See `cleanEnv`.
 125                    -- Future work:
 126                    -- Add a new MVar just for saving.
 127                  }
 128
 129 readRepoEnv :: FilePath -> IO RepoEnv
 130 readRepoEnv repoDir = do
 131   -- Does file exist ? :: Bool
 132   _repoDir <- createDirectoryIfMissing True repoDir
 133
 134   repoFile <- doesFileExist (repoSnapshot repoDir)
 135
 136   -- Is file not empty ? :: Bool
 137   repoExists <- if repoFile
 138              then (>0) <$> getFileSize (repoSnapshot repoDir)
 139              else pure False
 140
 141   mlock <- tryLockFile (repoSnapshot repoDir) Exclusive
 142   lock <- maybe (panic "Repo file already locked") pure mlock
 143
 144   mvar <- newMVar =<<
 145     if repoExists
 146       then do
 147         -- e_repo <- eitherDecodeStrict <$> deserialise <$> L.readFile repoSnapshot
 148         repo <- deserialise <$> L.readFile (repoSnapshot repoDir)
 149         -- repo   <- either fail pure e_repo
 150         let archive = (repoSnapshot repoDir) <> ".v" <> show (repo ^. r_version)
 151         copyFile (repoSnapshot repoDir) archive
 152         pure repo
 153       else
 154         pure initRepo
 155   -- TODO save in DB here
 156   saver <- mkRepoSaver repoDir mvar
 157   pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
 158
 159 devJwkFile :: FilePath
 160 devJwkFile = "dev.jwk"
 161
 162 newEnv :: PortNumber -> FilePath -> IO Env
 163 newEnv port file = do
 164   manager     <- newTlsManager
 165   settings    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
 166   when (port /= settings ^. appPort) $
 167     panic "TODO: conflicting settings of port"
 168
 169   config       <- readConfig file
 170   self_url     <- parseBaseUrl $ "http://0.0.0.0:" <> show port
 171   dbParam      <- databaseParameters file
 172   pool         <- newPool dbParam
 173   repo         <- readRepoEnv (_gc_repofilepath config)
 174   scrapers_env <- newJobEnv defaultSettings manager
 175   logger       <- newStderrLoggerSet defaultBufSize
 176
 177   pure $ Env
 178     { _env_settings   = settings
 179     , _env_logger     = logger
 180     , _env_pool       = pool
 181     , _env_repo       = repo
 182     , _env_manager    = manager
 183     , _env_scrapers   = scrapers_env
 184     , _env_self_url   = self_url
 185     , _env_gargConfig = config
 186     }
 187
 188 newPool :: ConnectInfo -> IO (Pool Connection)
 189 newPool param = createPool (connect param) close 1 (60*60) 8
 190
 191 cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
 192 cleanEnv env = do
 193   r <- takeMVar (env ^. repoEnv . renv_var)
 194   repoSaverAction (env ^. hasConfig . gc_repofilepath) r
 195   unlockFile (env ^. repoEnv . renv_lock)
 196
 197 type IniPath  = FilePath
 198 withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
 199 withDevEnv iniPath k = do
 200   env <- newDevEnv
 201   k env `finally` cleanEnv env
 202
 203   where
 204     newDevEnv = do
 205       config  <- readConfig         iniPath
 206       dbParam <- databaseParameters iniPath
 207       pool    <- newPool            dbParam
 208       repo    <- readRepoEnv        (_gc_repofilepath config)
 209       setts   <- devSettings devJwkFile
 210       pure $ DevEnv
 211         { _dev_env_pool = pool
 212         , _dev_env_repo = repo
 213         , _dev_env_settings = setts
 214         , _dev_env_config   = config
 215         }
 216
 217 -- | Run Cmd Sugar for the Repl (GHCI)
 218
 219 runCmdRepl :: Show err => Cmd' DevEnv err a -> IO a
 220 runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
 221
 222 runCmdReplServantErr :: Cmd' DevEnv ServerError a -> IO a
 223 runCmdReplServantErr = runCmdRepl
 224
 225 -- Use only for dev
 226 -- In particular this writes the repo file after running
 227 -- the command.
 228 -- This function is constrained to the DevEnv rather than
 229 -- using HasConnectionPool and HasRepoVar.
 230 runCmdDev :: Show err => DevEnv -> Cmd' DevEnv err a -> IO a
 231 runCmdDev env f =
 232   (either (fail . show) pure =<< runCmd env f)
 233     `finally`
 234   runReaderT saveRepo env
 235
 236 -- Use only for dev
 237 runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
 238 runCmdDevNoErr = runCmdDev
 239
 240 -- Use only for dev
 241 runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
 242 runCmdDevServantErr = runCmdDev