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 NoImplicitPrelude   #-}
  20 {-# LANGUAGE OverloadedStrings   #-}
  21 {-# LANGUAGE RankNTypes          #-}
  22 {-# LANGUAGE ScopedTypeVariables #-}
  23 {-# LANGUAGE TemplateHaskell     #-}
  24
  25 module Gargantext.API.Settings
  26     where
  27
  28 import System.Directory
  29 import System.Log.FastLogger
  30 import GHC.Enum
  31 import GHC.Generics (Generic)
  32 import Prelude (Bounded(), fail)
  33 import System.Environment (lookupEnv)
  34 import System.IO (FilePath, hClose)
  35 import System.IO.Temp (withTempFile)
  36 import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
  37 import Database.PostgreSQL.Simple (Connection, connect)
  38 import Network.HTTP.Client (Manager)
  39 import Network.HTTP.Client.TLS (newTlsManager)
  40
  41 import Data.Aeson
  42 import Data.Maybe (fromMaybe)
  43 import Data.Either (either)
  44 import Data.Text
  45 --import Data.Text.Encoding (encodeUtf8)
  46 import Data.ByteString (ByteString)
  47 import qualified Data.ByteString.Lazy as L
  48
  49 import Servant
  50 import Servant.Auth.Server (defaultJWTSettings, JWTSettings, CookieSettings, defaultCookieSettings, readKey, writeKey)
  51 import Servant.Client (BaseUrl, parseBaseUrl)
  52 import Servant.Job.Async (newJobEnv, defaultSettings)
  53 import Web.HttpApiData (parseUrlPiece)
  54
  55 import Control.Concurrent
  56 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
  57 import Control.Exception (finally)
  58 import Control.Monad.Logger
  59 import Control.Monad.Reader
  60 import Control.Lens
  61 import Gargantext.Prelude
  62 import Gargantext.Database.Utils (databaseParameters, HasConnection(..), Cmd', runCmd)
  63 import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..), r_version, saveRepo, initRepo, renv_var, renv_lock)
  64 import Gargantext.API.Orchestrator.Types
  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 class HasScrapers env where
  94   scrapers :: Getter env ScrapersEnv
  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 -- TODO-SECURITY tune
 111     , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
 112     }
 113
 114
 115
 116 reqSetting :: FromHttpApiData a => Text -> IO a
 117 reqSetting name = do
 118     e <- fromMaybe (panic $ "Missing " <> name) <$> lookupEnv (unpack name)
 119     pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
 120
 121 optSetting :: FromHttpApiData a => Text -> a -> IO a
 122 optSetting name d = do
 123     me <- lookupEnv (unpack name)
 124     case me of
 125         Nothing -> pure d
 126         Just e -> pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
 127
 128 --settingsFromEnvironment :: IO Settings
 129 --settingsFromEnvironment =
 130 --    Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
 131 --             <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
 132 --             <*> optSetting "PORT" 3000
 133 --             <*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn")
 134 --             <*> reqSetting "DB_SERVER"
 135 --             <*> (parseJwk <$> reqSetting "JWT_SECRET")
 136 --             <*> optSetting "SEND_EMAIL" SendEmailViaAws
 137
 138 data FireWall = FireWall { unFireWall :: Bool }
 139
 140 data Env = Env
 141   { _env_settings :: !Settings
 142   , _env_logger   :: !LoggerSet
 143   , _env_conn     :: !Connection
 144   , _env_repo     :: !RepoEnv
 145   , _env_manager  :: !Manager
 146   , _env_self_url :: !BaseUrl
 147   , _env_scrapers :: !ScrapersEnv
 148   }
 149   deriving (Generic)
 150
 151 makeLenses ''Env
 152
 153 instance HasConnection Env where
 154   connection = env_conn
 155
 156 instance HasRepoVar Env where
 157   repoVar = repoEnv . repoVar
 158
 159 instance HasRepoSaver Env where
 160   repoSaver = repoEnv . repoSaver
 161
 162 instance HasRepo Env where
 163   repoEnv = env_repo
 164
 165 instance HasSettings Env where
 166   settings = env_settings
 167
 168 instance HasScrapers Env where
 169   scrapers = env_scrapers
 170
 171 data MockEnv = MockEnv
 172   { _menv_firewall :: !FireWall
 173   }
 174   deriving (Generic)
 175
 176 makeLenses ''MockEnv
 177
 178 -- | TODO add this path in Settings
 179 repoSnapshot :: FilePath
 180 repoSnapshot = "repo.json"
 181
 182 -- | TODO add hard coded file in Settings
 183 -- This assumes we own the lock on repoSnapshot.
 184 repoSaverAction :: ToJSON a => a -> IO ()
 185 repoSaverAction a = do
 186   withTempFile "." "tmp-repo.json" $ \fp h -> do
 187     -- printDebug "repoSaverAction" fp
 188     L.hPut h $ encode a
 189     hClose h
 190     renameFile fp repoSnapshot
 191
 192 mkRepoSaver :: MVar NgramsRepo -> IO (IO ())
 193 mkRepoSaver repo_var = mkDebounce settings
 194   where
 195     settings = defaultDebounceSettings
 196                  { debounceFreq   = 1000000 -- 1 second
 197                  , debounceAction = withMVar repo_var repoSaverAction
 198                    -- Here this not only `readMVar` but `takeMVar`.
 199                    -- Namely while repoSaverAction is saving no other change
 200                    -- can be made to the MVar.
 201                    -- This might be not efficent and thus reconsidered later.
 202                    -- However this enables to safely perform a *final* save.
 203                    -- See `cleanEnv`.
 204                    -- Future work:
 205                    -- Add a new MVar just for saving.
 206                  }
 207
 208 readRepoEnv :: IO RepoEnv
 209 readRepoEnv = do
 210   -- Does file exist ? :: Bool
 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 <- eitherDecodeFileStrict repoSnapshot
 225         repo   <- either fail pure e_repo
 226         let archive = repoSnapshot <> ".v" <> show (repo ^. r_version)
 227         copyFile repoSnapshot archive
 228         pure repo
 229       else
 230         pure initRepo
 231
 232   saver <- mkRepoSaver mvar
 233   pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
 234
 235 devJwkFile :: FilePath
 236 devJwkFile = "dev.jwk"
 237
 238 newEnv :: PortNumber -> FilePath -> IO Env
 239 newEnv port file = do
 240   manager <- newTlsManager
 241   settings <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
 242   when (port /= settings ^. appPort) $
 243     panic "TODO: conflicting settings of port"
 244
 245   self_url <- parseBaseUrl $ "http://0.0.0.0:" <> show port
 246   param    <- databaseParameters file
 247   conn     <- connect param
 248   repo     <- readRepoEnv
 249   scrapers_env <- newJobEnv defaultSettings manager
 250   logger <- newStderrLoggerSet defaultBufSize
 251
 252   pure $ Env
 253     { _env_settings   = settings
 254     , _env_logger     = logger
 255     , _env_conn       = conn
 256     , _env_repo       = repo
 257     , _env_manager    = manager
 258     , _env_scrapers   = scrapers_env
 259     , _env_self_url   = self_url
 260     }
 261
 262 data DevEnv = DevEnv
 263   { _dev_env_conn :: !Connection
 264   , _dev_env_repo :: !RepoEnv
 265   , _dev_env_settings :: !Settings
 266   }
 267
 268 makeLenses ''DevEnv
 269
 270 instance HasConnection DevEnv where
 271   connection = dev_env_conn
 272
 273 instance HasRepoVar DevEnv where
 274   repoVar = repoEnv . repoVar
 275
 276 instance HasRepoSaver DevEnv where
 277   repoSaver = repoEnv . repoSaver
 278
 279 instance HasRepo DevEnv where
 280   repoEnv = dev_env_repo
 281
 282 instance HasSettings DevEnv where
 283   settings = dev_env_settings
 284
 285 cleanEnv :: HasRepo env => env -> IO ()
 286 cleanEnv env = do
 287   r <- takeMVar (env ^. repoEnv . renv_var)
 288   repoSaverAction r
 289   unlockFile (env ^. repoEnv . renv_lock)
 290
 291 withDevEnv :: FilePath -> (DevEnv -> IO a) -> IO a
 292 withDevEnv iniPath k = do
 293   env <- newDevEnv
 294   k env `finally` cleanEnv env
 295
 296   where
 297     newDevEnv = do
 298       param <- databaseParameters iniPath
 299       conn  <- connect param
 300       repo  <- readRepoEnv
 301       setts <- devSettings devJwkFile
 302       pure $ DevEnv
 303         { _dev_env_conn = conn
 304         , _dev_env_repo = repo
 305         , _dev_env_settings = setts
 306         }
 307
 308 -- | Run Cmd Sugar for the Repl (GHCI)
 309 runCmdRepl :: Show err => Cmd' DevEnv err a -> IO a
 310 runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
 311
 312 runCmdReplServantErr :: Cmd' DevEnv ServerError a -> IO a
 313 runCmdReplServantErr = runCmdRepl
 314
 315 -- Use only for dev
 316 -- In particular this writes the repo file after running
 317 -- the command.
 318 -- This function is constrained to the DevEnv rather than
 319 -- using HasConnection and HasRepoVar.
 320 runCmdDev :: Show err => DevEnv -> Cmd' DevEnv err a -> IO a
 321 runCmdDev env f =
 322   (either (fail . show) pure =<< runCmd env f)
 323     `finally`
 324   runReaderT saveRepo env
 325
 326 -- Use only for dev
 327 runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
 328 runCmdDevNoErr = runCmdDev
 329
 330 -- Use only for dev
 331 runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
 332 runCmdDevServantErr = runCmdDev