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(), 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 -- | TODO add this path in Settings
 175
 176 repoDir :: FilePath
 177 repoDir = "repos"
 178
 179 repoSnapshot :: FilePath
 180 repoSnapshot = repoDir <> "/repo.cbor"
 181
 182 -- | TODO add hard coded file in Settings
 183 -- This assumes we own the lock on repoSnapshot.
 184 repoSaverAction :: Serialise a => a -> IO ()
 185 repoSaverAction a = do
 186   withTempFile "repos" "tmp-repo.cbor" $ \fp h -> do
 187     printDebug "repoSaverAction" fp
 188     L.hPut h $ serialise a
 189     hClose h
 190     renameFile fp repoSnapshot
 191
 192 mkRepoSaver :: MVar NgramsRepo -> IO (IO ())
 193 mkRepoSaver repo_var = mkDebounce settings
 194   where
 195     settings = defaultDebounceSettings
 196                  { debounceFreq   = let n = 6 :: Int in 10^n  -- 1 second
 197                  , debounceAction = withMVar repo_var repoSaverAction
 198                    -- Here this not only `readMVar` but `takeMVar`.
 199                    -- Namely while repoSaverAction is saving no other change
 200                    -- can be made to the MVar.
 201                    -- This might be not efficent and thus reconsidered later.
 202                    -- However this enables to safely perform a *final* save.
 203                    -- See `cleanEnv`.
 204                    -- Future work:
 205                    -- Add a new MVar just for saving.
 206                  }
 207
 208 readRepoEnv :: IO RepoEnv
 209 readRepoEnv = do
 210   -- Does file exist ? :: Bool
 211   _repoDir <- createDirectoryIfMissing True repoDir
 212
 213   repoFile <- doesFileExist repoSnapshot
 214
 215   -- Is file not empty ? :: Bool
 216   repoExists <- if repoFile
 217              then (>0) <$> getFileSize repoSnapshot
 218              else pure False
 219
 220   mlock <- tryLockFile repoSnapshot Exclusive
 221   lock <- maybe (panic "Repo file already locked") pure mlock
 222
 223   mvar <- newMVar =<<
 224     if repoExists
 225       then do
 226         -- e_repo <- eitherDecodeStrict <$> deserialise <$> L.readFile repoSnapshot
 227         repo <- deserialise <$> L.readFile repoSnapshot
 228         -- repo   <- either fail pure e_repo
 229         let archive = repoSnapshot <> ".v" <> show (repo ^. r_version)
 230         copyFile repoSnapshot archive
 231         pure repo
 232       else
 233         pure initRepo
 234   -- TODO save in DB here
 235   saver <- mkRepoSaver mvar
 236   pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
 237
 238 devJwkFile :: FilePath
 239 devJwkFile = "dev.jwk"
 240
 241 newEnv :: PortNumber -> FilePath -> IO Env
 242 newEnv port file = do
 243   manager     <- newTlsManager
 244   settings    <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
 245   when (port /= settings ^. appPort) $
 246     panic "TODO: conflicting settings of port"
 247
 248   self_url     <- parseBaseUrl $ "http://0.0.0.0:" <> show port
 249   param        <- databaseParameters file
 250   pool         <- newPool param
 251   repo         <- readRepoEnv
 252   scrapers_env <- newJobEnv defaultSettings manager
 253   logger       <- newStderrLoggerSet defaultBufSize
 254   config       <- readConfig file
 255
 256   pure $ Env
 257     { _env_settings   = settings
 258     , _env_logger     = logger
 259     , _env_pool       = pool
 260     , _env_repo       = repo
 261     , _env_manager    = manager
 262     , _env_scrapers   = scrapers_env
 263     , _env_self_url   = self_url
 264     , _env_gargConfig = config
 265     }
 266
 267 newPool :: ConnectInfo -> IO (Pool Connection)
 268 newPool param = createPool (connect param) close 1 (60*60) 8
 269
 270 data DevEnv = DevEnv
 271   { _dev_env_pool     :: !(Pool Connection)
 272   , _dev_env_repo     :: !RepoEnv
 273   , _dev_env_settings :: !Settings
 274   , _dev_env_config   :: !GargConfig
 275   }
 276
 277 makeLenses ''DevEnv
 278
 279 instance HasConfig DevEnv where
 280   hasConfig = dev_env_config
 281
 282 instance HasConnectionPool DevEnv where
 283   connPool = dev_env_pool
 284
 285 instance HasRepoVar DevEnv where
 286   repoVar = repoEnv . repoVar
 287
 288 instance HasRepoSaver DevEnv where
 289   repoSaver = repoEnv . repoSaver
 290
 291 instance HasRepo DevEnv where
 292   repoEnv = dev_env_repo
 293
 294 instance HasSettings DevEnv where
 295   settings = dev_env_settings
 296
 297 cleanEnv :: HasRepo env => env -> IO ()
 298 cleanEnv env = do
 299   r <- takeMVar (env ^. repoEnv . renv_var)
 300   repoSaverAction r
 301   unlockFile (env ^. repoEnv . renv_lock)
 302
 303 withDevEnv :: FilePath -> (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       param <- databaseParameters iniPath
 311       pool  <- newPool param
 312       repo  <- readRepoEnv
 313       setts <- devSettings devJwkFile
 314       config <- readConfig iniPath
 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