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