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.ByteString (ByteString)
  29 import Data.Maybe (fromMaybe)
  30 import Data.Pool (Pool, createPool)
  31 import Data.Text
  32 import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
  33 import GHC.Enum
  34 import GHC.Generics (Generic)
  35 import Gargantext.API.Admin.Orchestrator.Types
  36 import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..), r_version, saveRepo, initRepo, renv_var, renv_lock)
  37 import Gargantext.Database.Prelude (databaseParameters, HasConnectionPool(..), Cmd', runCmd, HasConfig(..))
  38 import Gargantext.Prelude
  39
  40 import Network.HTTP.Client (Manager)
  41 import Network.HTTP.Client.TLS (newTlsManager)
  42 import Servant
  43 import Servant.Auth.Server (defaultJWTSettings, JWTSettings, CookieSettings(..), XsrfCookieSettings(..), defaultCookieSettings, defaultXsrfCookieSettings, readKey, writeKey)
  44 import Servant.Client (BaseUrl, parseBaseUrl)
  45 import Servant.Job.Async (newJobEnv, defaultSettings, HasJobEnv(..), Job)
  46 import System.Directory
  47 import System.Environment (lookupEnv)
  48 import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
  49 import System.IO (FilePath, hClose)
  50 import System.IO.Temp (withTempFile)
  51 import System.Log.FastLogger
  52 import qualified Data.ByteString.Lazy as L
  53 import qualified Servant.Job.Core
  54 import Gargantext.Prelude.Config (GargConfig(..), gc_repofilepath, readConfig, defaultConfig)
  55
  56 type PortNumber = Int
  57
  58 data SendEmailType = SendEmailViaAws
  59                    | LogEmailToConsole
  60                    | WriteEmailToFile
  61     deriving (Show, Read, Enum, Bounded, Generic)
  62
  63
  64 data Settings = Settings
  65     { _allowedOrigin   :: ByteString   -- allowed origin for CORS
  66     , _allowedHost     :: ByteString   -- allowed host for CORS
  67     , _appPort         :: PortNumber
  68     , _logLevelLimit   :: LogLevel -- log level from the monad-logger package
  69 --    , _dbServer        :: Text
  70 --    ^ this is not used yet
  71     , _jwtSettings     :: JWTSettings
  72     , _cookieSettings  :: CookieSettings
  73     , _sendLoginEmails :: SendEmailType
  74     , _scrapydUrl      :: BaseUrl
  75     , _config          :: GargConfig
  76     }
  77
  78 makeLenses ''Settings
  79
  80 class HasSettings env where
  81   settings :: Getter env Settings
  82
  83 devSettings :: FilePath -> IO Settings
  84 devSettings jwkFile = do
  85   jwkExists <- doesFileExist jwkFile
  86   when (not jwkExists) $ writeKey jwkFile
  87   jwk       <- readKey jwkFile
  88   pure $ Settings
  89     { _allowedOrigin = "http://localhost:8008"
  90     , _allowedHost = "localhost:3000"
  91     , _appPort = 3000
  92     , _logLevelLimit = LevelDebug
  93 --    , _dbServer = "localhost"
  94     , _sendLoginEmails = LogEmailToConsole
  95     , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
  96     , _cookieSettings = defaultCookieSettings { cookieXsrfSetting = Just xsrfCookieSetting } -- TODO-SECURITY tune
  97     , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
  98     , _config      = defaultConfig
  99     }
 100   where
 101     xsrfCookieSetting = defaultXsrfCookieSettings { xsrfExcludeGet = True }
 102
 103
 104
 105 reqSetting :: FromHttpApiData a => Text -> IO a
 106 reqSetting name = do
 107     e <- fromMaybe (panic $ "Missing " <> name) <$> lookupEnv (unpack name)
 108     pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
 109
 110 optSetting :: FromHttpApiData a => Text -> a -> IO a
 111 optSetting name d = do
 112     me <- lookupEnv (unpack name)
 113     case me of
 114         Nothing -> pure d
 115         Just e -> pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
 116
 117 --settingsFromEnvironment :: IO Settings
 118 --settingsFromEnvironment =
 119 --    Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
 120 --             <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
 121 --             <*> optSetting "PORT" 3000
 122 --             <*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn")
 123 --             <*> reqSetting "DB_SERVER"
 124 --             <*> (parseJwk <$> reqSetting "JWT_SECRET")
 125 --             <*> optSetting "SEND_EMAIL" SendEmailViaAws
 126
 127 data FireWall = FireWall { unFireWall :: Bool }
 128
 129 data Env = Env
 130   { _env_settings :: !Settings
 131   , _env_logger   :: !LoggerSet
 132   , _env_pool     :: !(Pool Connection)
 133   , _env_repo     :: !RepoEnv
 134   , _env_manager  :: !Manager
 135   , _env_self_url :: !BaseUrl
 136   , _env_scrapers :: !ScrapersEnv
 137   , _env_gargConfig :: !GargConfig
 138   }
 139   deriving (Generic)
 140
 141 makeLenses ''Env
 142
 143 instance HasConfig Env where
 144   hasConfig = env_gargConfig
 145
 146 instance HasConnectionPool Env where
 147   connPool = env_pool
 148
 149 instance HasRepoVar Env where
 150   repoVar = repoEnv . repoVar
 151
 152 instance HasRepoSaver Env where
 153   repoSaver = repoEnv . repoSaver
 154
 155 instance HasRepo Env where
 156   repoEnv = env_repo
 157
 158 instance HasSettings Env where
 159   settings = env_settings
 160
 161 instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
 162   _env = env_scrapers . Servant.Job.Core._env
 163
 164 instance HasJobEnv Env JobLog JobLog where
 165   job_env = env_scrapers
 166
 167 data MockEnv = MockEnv
 168   { _menv_firewall :: !FireWall
 169   }
 170   deriving (Generic)
 171
 172 makeLenses ''MockEnv
 173
 174 -----------------------------------------------------------------------
 175 -- | RepoDir FilePath configuration
 176 type RepoDirFilePath = FilePath
 177
 178 repoSnapshot :: RepoDirFilePath -> FilePath
 179 repoSnapshot repoDir = repoDir <> "/repo.cbor"
 180
 181 -- | TODO add hard coded file in Settings
 182 -- This assumes we own the lock on repoSnapshot.
 183 repoSaverAction :: RepoDirFilePath -> Serialise a => a -> IO ()
 184 repoSaverAction repoDir a = do
 185   withTempFile "repos" "tmp-repo.cbor" $ \fp h -> do
 186     printDebug "repoSaverAction" fp
 187     L.hPut h $ serialise a
 188     hClose h
 189     renameFile fp (repoSnapshot repoDir)
 190
 191 mkRepoSaver :: RepoDirFilePath -> MVar NgramsRepo -> IO (IO ())
 192 mkRepoSaver repoDir repo_var = mkDebounce settings
 193   where
 194     settings = defaultDebounceSettings
 195                  { debounceFreq   = let n = 6 :: Int in 10^n  -- 1 second
 196                  , debounceAction = withMVar repo_var (repoSaverAction repoDir)
 197                    -- Here this not only `readMVar` but `takeMVar`.
 198                    -- Namely while repoSaverAction is saving no other change
 199                    -- can be made to the MVar.
 200                    -- This might be not efficent and thus reconsidered later.
 201                    -- However this enables to safely perform a *final* save.
 202                    -- See `cleanEnv`.
 203                    -- Future work:
 204                    -- Add a new MVar just for saving.
 205                  }
 206
 207 readRepoEnv :: FilePath -> IO RepoEnv
 208 readRepoEnv repoDir = do
 209   -- Does file exist ? :: Bool
 210   _repoDir <- createDirectoryIfMissing True repoDir
 211
 212   repoFile <- doesFileExist (repoSnapshot repoDir)
 213
 214   -- Is file not empty ? :: Bool
 215   repoExists <- if repoFile
 216              then (>0) <$> getFileSize (repoSnapshot repoDir)
 217              else pure False
 218
 219   mlock <- tryLockFile (repoSnapshot repoDir) Exclusive
 220   lock <- maybe (panic "Repo file already locked") pure mlock
 221
 222   mvar <- newMVar =<<
 223     if repoExists
 224       then do
 225         -- e_repo <- eitherDecodeStrict <$> deserialise <$> L.readFile repoSnapshot
 226         repo <- deserialise <$> L.readFile (repoSnapshot repoDir)
 227         -- repo   <- either fail pure e_repo
 228         let archive = (repoSnapshot repoDir) <> ".v" <> show (repo ^. r_version)
 229         copyFile (repoSnapshot repoDir) archive
 230         pure repo
 231       else
 232         pure initRepo
 233   -- TODO save in DB here
 234   saver <- mkRepoSaver repoDir mvar
 235   pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
 236
 237 devJwkFile :: FilePath
 238 devJwkFile = "dev.jwk"
 239
 240 newEnv :: PortNumber -> FilePath -> IO Env
 241 newEnv port file = do
 242   manager     <- newTlsManager
 243   settings    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
 244   when (port /= settings ^. appPort) $
 245     panic "TODO: conflicting settings of port"
 246
 247   config       <- readConfig file
 248   self_url     <- parseBaseUrl $ "http://0.0.0.0:" <> show port
 249   dbParam      <- databaseParameters file
 250   pool         <- newPool dbParam
 251   repo         <- readRepoEnv (_gc_repofilepath config)
 252   scrapers_env <- newJobEnv defaultSettings manager
 253   logger       <- newStderrLoggerSet defaultBufSize
 254
 255   pure $ Env
 256     { _env_settings   = settings
 257     , _env_logger     = logger
 258     , _env_pool       = pool
 259     , _env_repo       = repo
 260     , _env_manager    = manager
 261     , _env_scrapers   = scrapers_env
 262     , _env_self_url   = self_url
 263     , _env_gargConfig = config
 264     }
 265
 266 newPool :: ConnectInfo -> IO (Pool Connection)
 267 newPool param = createPool (connect param) close 1 (60*60) 8
 268
 269 data DevEnv = DevEnv
 270   { _dev_env_pool     :: !(Pool Connection)
 271   , _dev_env_repo     :: !RepoEnv
 272   , _dev_env_settings :: !Settings
 273   , _dev_env_config   :: !GargConfig
 274   }
 275
 276 makeLenses ''DevEnv
 277
 278 instance HasConfig DevEnv where
 279   hasConfig = dev_env_config
 280
 281 instance HasConnectionPool DevEnv where
 282   connPool = dev_env_pool
 283
 284 instance HasRepoVar DevEnv where
 285   repoVar = repoEnv . repoVar
 286
 287 instance HasRepoSaver DevEnv where
 288   repoSaver = repoEnv . repoSaver
 289
 290 instance HasRepo DevEnv where
 291   repoEnv = dev_env_repo
 292
 293 instance HasSettings DevEnv where
 294   settings = dev_env_settings
 295
 296 cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
 297 cleanEnv env = do
 298   r <- takeMVar (env ^. repoEnv . renv_var)
 299   repoSaverAction (env ^. hasConfig . gc_repofilepath) r
 300   unlockFile (env ^. repoEnv . renv_lock)
 301
 302 type IniPath  = FilePath
 303 withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
 304 withDevEnv iniPath k = do
 305   env <- newDevEnv
 306   k env `finally` cleanEnv env
 307
 308   where
 309     newDevEnv = do
 310       config  <- readConfig         iniPath
 311       dbParam <- databaseParameters iniPath
 312       pool    <- newPool            dbParam
 313       repo    <- readRepoEnv        (_gc_repofilepath config)
 314       setts   <- devSettings devJwkFile
 315       pure $ DevEnv
 316         { _dev_env_pool = pool
 317         , _dev_env_repo = repo
 318         , _dev_env_settings = setts
 319         , _dev_env_config   = config
 320         }
 321
 322 -- | Run Cmd Sugar for the Repl (GHCI)
 323
 324 runCmdRepl :: Show err => Cmd' DevEnv err a -> IO a
 325 runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
 326
 327 runCmdReplServantErr :: Cmd' DevEnv ServerError a -> IO a
 328 runCmdReplServantErr = runCmdRepl
 329
 330 -- Use only for dev
 331 -- In particular this writes the repo file after running
 332 -- the command.
 333 -- This function is constrained to the DevEnv rather than
 334 -- using HasConnectionPool and HasRepoVar.
 335 runCmdDev :: Show err => DevEnv -> Cmd' DevEnv err a -> IO a
 336 runCmdDev env f =
 337   (either (fail . show) pure =<< runCmd env f)
 338     `finally`
 339   runReaderT saveRepo env
 340
 341 -- Use only for dev
 342 runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
 343 runCmdDevNoErr = runCmdDev
 344
 345 -- Use only for dev
 346 runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
 347 runCmdDevServantErr = runCmdDev