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