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