src/Gargantext/API/Settings.hs

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