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