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 Codec.Serialise (Serialise(), serialise, deserialise)
  30 import Control.Concurrent
  31 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
  32 import Control.Exception (finally)
  33 import Control.Lens
  34 import Control.Monad.Logger
  35 import Control.Monad.Reader
  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 :: Serialise a => a -> IO ()
 191 repoSaverAction a = do
 192   withTempFile "repos" "tmp-repo.json" $ \fp h -> do
 193     printDebug "repoSaverAction" fp
 194     L.hPut h $ serialise 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 <- eitherDecodeStrict <$> deserialise <$> L.readFile repoSnapshot
 233         repo <- deserialise <$> L.readFile repoSnapshot
 234         -- repo   <- either fail pure e_repo
 235         let archive = repoSnapshot <> ".v" <> show (repo ^. r_version)
 236         copyFile repoSnapshot archive
 237         pure repo
 238       else
 239         pure initRepo
 240   -- TODO save in DB here
 241   saver <- mkRepoSaver mvar
 242   pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
 243
 244 devJwkFile :: FilePath
 245 devJwkFile = "dev.jwk"
 246
 247 newEnv :: PortNumber -> FilePath -> IO Env
 248 newEnv port file = do
 249   manager <- newTlsManager
 250   settings <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
 251   when (port /= settings ^. appPort) $
 252     panic "TODO: conflicting settings of port"
 253
 254   self_url <- parseBaseUrl $ "http://0.0.0.0:" <> show port
 255   param    <- databaseParameters file
 256   pool     <- newPool param
 257   repo     <- readRepoEnv
 258   scrapers_env <- newJobEnv defaultSettings manager
 259   logger <- newStderrLoggerSet defaultBufSize
 260
 261   pure $ Env
 262     { _env_settings   = settings
 263     , _env_logger     = logger
 264     , _env_pool       = pool
 265     , _env_repo       = repo
 266     , _env_manager    = manager
 267     , _env_scrapers   = scrapers_env
 268     , _env_self_url   = self_url
 269     }
 270
 271 newPool :: ConnectInfo -> IO (Pool Connection)
 272 newPool param = createPool (connect param) close 1 (60*60) 8
 273
 274 data DevEnv = DevEnv
 275   { _dev_env_pool :: !(Pool Connection)
 276   , _dev_env_repo :: !RepoEnv
 277   , _dev_env_settings :: !Settings
 278   }
 279
 280 makeLenses ''DevEnv
 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       pure $ DevEnv
 315         { _dev_env_pool = pool
 316         , _dev_env_repo = repo
 317         , _dev_env_settings = setts
 318         }
 319
 320 -- | Run Cmd Sugar for the Repl (GHCI)
 321 runCmdRepl :: Show err => Cmd' DevEnv err a -> IO a
 322 runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
 323
 324 runCmdReplServantErr :: Cmd' DevEnv ServerError a -> IO a
 325 runCmdReplServantErr = runCmdRepl
 326
 327 -- Use only for dev
 328 -- In particular this writes the repo file after running
 329 -- the command.
 330 -- This function is constrained to the DevEnv rather than
 331 -- using HasConnectionPool and HasRepoVar.
 332 runCmdDev :: Show err => DevEnv -> Cmd' DevEnv err a -> IO a
 333 runCmdDev env f =
 334   (either (fail . show) pure =<< runCmd env f)
 335     `finally`
 336   runReaderT saveRepo env
 337
 338 -- Use only for dev
 339 runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
 340 runCmdDevNoErr = runCmdDev
 341
 342 -- Use only for dev
 343 runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
 344 runCmdDevServantErr = runCmdDev