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
  50 devSettings :: FilePath -> IO Settings
  51 devSettings jwkFile = do
  52   jwkExists <- doesFileExist jwkFile
  53   when (not jwkExists) $ writeKey jwkFile
  54   jwk       <- readKey jwkFile
  55   pure $ Settings
  56     { _allowedOrigin = "http://localhost:8008"
  57     , _allowedHost = "localhost:3000"
  58     , _appPort = 3000
  59     , _logLevelLimit = LevelDebug
  60 --    , _dbServer = "localhost"
  61     , _sendLoginEmails = LogEmailToConsole
  62     , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
  63     , _cookieSettings = defaultCookieSettings { cookieXsrfSetting = Just xsrfCookieSetting } -- TODO-SECURITY tune
  64     , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
  65     }
  66   where
  67     xsrfCookieSetting = defaultXsrfCookieSettings { xsrfExcludeGet = True }
  68
  69 {- NOT USED YET
  70 import System.Environment (lookupEnv)
  71
  72 reqSetting :: FromHttpApiData a => Text -> IO a
  73 reqSetting name = do
  74     e <- fromMaybe (panic $ "Missing " <> name) <$> lookupEnv (unpack name)
  75     pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
  76
  77 optSetting :: FromHttpApiData a => Text -> a -> IO a
  78 optSetting name d = do
  79     me <- lookupEnv (unpack name)
  80     case me of
  81         Nothing -> pure d
  82         Just e -> pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
  83
  84 settingsFromEnvironment :: IO Settings
  85 settingsFromEnvironment =
  86     Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
  87              <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
  88              <*> optSetting "PORT" 3000
  89              <*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn")
  90              <*> reqSetting "DB_SERVER"
  91              <*> (parseJwk <$> reqSetting "JWT_SECRET")
  92              <*> optSetting "SEND_EMAIL" SendEmailViaAws
  93 -}
  94
  95 -----------------------------------------------------------------------
  96 -- | RepoDir FilePath configuration
  97 type RepoDirFilePath = FilePath
  98
  99 repoSnapshot :: RepoDirFilePath -> FilePath
 100 repoSnapshot repoDir = repoDir <> "/repo.cbor"
 101
 102
 103
 104 -- This assumes we own the lock on repoSnapshot.
 105 repoSaverAction :: RepoDirFilePath -> Serialise a => a -> IO ()
 106 repoSaverAction repoDir a = do
 107   withTempFile repoDir "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
 114
 115 {-
 116 -- The use of mkDebounce makes sure that repoSaverAction is not called too often.
 117 -- If repoSaverAction start taking more time than the debounceFreq then it should
 118 -- be increased.
 119 mkRepoSaver :: RepoDirFilePath -> MVar NgramsRepo -> IO (IO ())
 120 mkRepoSaver repoDir repo_var = mkDebounce settings'
 121   where
 122     settings' = defaultDebounceSettings
 123                  { debounceFreq   = let n = 6 :: Int in 10^n  -- 1 second
 124                  , debounceAction = withMVar repo_var (repoSaverAction repoDir)
 125                    -- Here this not only `readMVar` but `takeMVar`.
 126                    -- Namely while repoSaverAction is saving no other change
 127                    -- can be made to the MVar.
 128                    -- This might be not efficent and thus reconsidered later.
 129                    -- However this enables to safely perform a *final* save.
 130                    -- See `cleanEnv`.
 131                    -- Future work:
 132                    -- Add a new MVar just for saving.
 133                  }
 134
 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
 168 devJwkFile :: FilePath
 169 devJwkFile = "dev.jwk"
 170
 171 newEnv :: PortNumber -> FilePath -> IO Env
 172 newEnv port file = do
 173   manager_env  <- newTlsManager
 174   settings'    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
 175   when (port /= settings' ^. appPort) $
 176     panic "TODO: conflicting settings of port"
 177
 178   config_env    <- readConfig file
 179   self_url_env  <- parseBaseUrl $ "http://0.0.0.0:" <> show port
 180   dbParam       <- databaseParameters file
 181   pool          <- newPool dbParam
 182   nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
 183   scrapers_env  <- newJobEnv defaultSettings manager_env
 184   logger        <- newStderrLoggerSet defaultBufSize
 185
 186   pure $ Env
 187     { _env_settings  = settings'
 188     , _env_logger    = logger
 189     , _env_pool      = pool
 190     , _env_nodeStory = nodeStory_env
 191     , _env_manager   = manager_env
 192     , _env_scrapers  = scrapers_env
 193     , _env_self_url  = self_url_env
 194     , _env_config    = config_env
 195     }
 196
 197 newPool :: ConnectInfo -> IO (Pool Connection)
 198 newPool param = createPool (connect param) close 1 (60*60) 8
 199
 200 {-
 201 cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
 202 cleanEnv env = do
 203   r <- takeMVar (env ^. repoEnv . renv_var)
 204   repoSaverAction (env ^. hasConfig . gc_repofilepath) r
 205   unlockFile (env ^. repoEnv . renv_lock)
 206 --}