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)
  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.Text
  46 --import Data.Text.Encoding (encodeUtf8)
  47 import Data.ByteString (ByteString)
  48 import qualified Data.ByteString.Lazy as L
  49
  50 import Servant
  51 import Servant.Auth.Server (defaultJWTSettings, JWTSettings, CookieSettings, defaultCookieSettings, readKey, writeKey)
  52 import Servant.Client (BaseUrl, parseBaseUrl)
  53 import qualified Servant.Job.Core
  54 import Servant.Job.Async (newJobEnv, defaultSettings, HasJobEnv(..), Job)
  55 import Web.HttpApiData (parseUrlPiece)
  56
  57 import Control.Concurrent
  58 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
  59 import Control.Exception (finally)
  60 import Control.Monad.Logger
  61 import Control.Monad.Reader
  62 import Control.Lens
  63 import Gargantext.Prelude
  64 import Gargantext.Database.Utils (databaseParameters, HasConnection(..), Cmd', runCmd)
  65 import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..), r_version, saveRepo, initRepo, renv_var, renv_lock)
  66 import Gargantext.API.Orchestrator.Types
  67
  68 type PortNumber = Int
  69
  70 data SendEmailType = SendEmailViaAws
  71                    | LogEmailToConsole
  72                    | WriteEmailToFile
  73     deriving (Show, Read, Enum, Bounded, Generic)
  74
  75
  76 data Settings = Settings
  77     { _allowedOrigin   :: ByteString   -- allowed origin for CORS
  78     , _allowedHost     :: ByteString   -- allowed host for CORS
  79     , _appPort         :: PortNumber
  80     , _logLevelLimit   :: LogLevel -- log level from the monad-logger package
  81 --    , _dbServer        :: Text
  82 --    ^ this is not used yet
  83     , _jwtSettings     :: JWTSettings
  84     , _cookieSettings  :: CookieSettings
  85     , _sendLoginEmails :: SendEmailType
  86     , _scrapydUrl      :: BaseUrl
  87     , _fileFolder      :: FilePath
  88     }
  89
  90 makeLenses ''Settings
  91
  92 class HasSettings env where
  93   settings :: Getter env Settings
  94
  95 devSettings :: FilePath -> IO Settings
  96 devSettings jwkFile = do
  97   jwkExists <- doesFileExist jwkFile
  98   when (not jwkExists) $ writeKey jwkFile
  99   jwk <- readKey jwkFile
 100   pure $ Settings
 101     { _allowedOrigin = "http://localhost:8008"
 102     , _allowedHost = "localhost:3000"
 103     , _appPort = 3000
 104     , _logLevelLimit = LevelDebug
 105 --    , _dbServer = "localhost"
 106     , _sendLoginEmails = LogEmailToConsole
 107     , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
 108     , _fileFolder = "data"
 109     , _cookieSettings = defaultCookieSettings -- TODO-SECURITY tune
 110     , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
 111     }
 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_conn     :: !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 HasConnection Env where
 153   connection = env_conn
 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   conn     <- connect 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_conn       = conn
 264     , _env_repo       = repo
 265     , _env_manager    = manager
 266     , _env_scrapers   = scrapers_env
 267     , _env_self_url   = self_url
 268     }
 269
 270 data DevEnv = DevEnv
 271   { _dev_env_conn :: !Connection
 272   , _dev_env_repo :: !RepoEnv
 273   , _dev_env_settings :: !Settings
 274   }
 275
 276 makeLenses ''DevEnv
 277
 278 instance HasConnection DevEnv where
 279   connection = dev_env_conn
 280
 281 instance HasRepoVar DevEnv where
 282   repoVar = repoEnv . repoVar
 283
 284 instance HasRepoSaver DevEnv where
 285   repoSaver = repoEnv . repoSaver
 286
 287 instance HasRepo DevEnv where
 288   repoEnv = dev_env_repo
 289
 290 instance HasSettings DevEnv where
 291   settings = dev_env_settings
 292
 293 cleanEnv :: HasRepo env => env -> IO ()
 294 cleanEnv env = do
 295   r <- takeMVar (env ^. repoEnv . renv_var)
 296   repoSaverAction r
 297   unlockFile (env ^. repoEnv . renv_lock)
 298
 299 withDevEnv :: FilePath -> (DevEnv -> IO a) -> IO a
 300 withDevEnv iniPath k = do
 301   env <- newDevEnv
 302   k env `finally` cleanEnv env
 303
 304   where
 305     newDevEnv = do
 306       param <- databaseParameters iniPath
 307       conn  <- connect param
 308       repo  <- readRepoEnv
 309       setts <- devSettings devJwkFile
 310       pure $ DevEnv
 311         { _dev_env_conn = conn
 312         , _dev_env_repo = repo
 313         , _dev_env_settings = setts
 314         }
 315
 316 -- | Run Cmd Sugar for the Repl (GHCI)
 317 runCmdRepl :: Show err => Cmd' DevEnv err a -> IO a
 318 runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
 319
 320 runCmdReplServantErr :: Cmd' DevEnv ServerError a -> IO a
 321 runCmdReplServantErr = runCmdRepl
 322
 323 -- Use only for dev
 324 -- In particular this writes the repo file after running
 325 -- the command.
 326 -- This function is constrained to the DevEnv rather than
 327 -- using HasConnection and HasRepoVar.
 328 runCmdDev :: Show err => DevEnv -> Cmd' DevEnv err a -> IO a
 329 runCmdDev env f =
 330   (either (fail . show) pure =<< runCmd env f)
 331     `finally`
 332   runReaderT saveRepo env
 333
 334 -- Use only for dev
 335 runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
 336 runCmdDevNoErr = runCmdDev
 337
 338 -- Use only for dev
 339 runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
 340 runCmdDevServantErr = runCmdDev