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