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