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(..), XsrfCookieSettings(..), defaultCookieSettings, defaultXsrfCookieSettings, 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 { cookieXsrfSetting = Just xsrfCookieSetting } -- TODO-SECURITY tune
 110     , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
 111     }
 112   where
 113     xsrfCookieSetting = defaultXsrfCookieSettings { xsrfExcludeGet = True }
 114
 115
 116
 117 reqSetting :: FromHttpApiData a => Text -> IO a
 118 reqSetting name = do
 119     e <- fromMaybe (panic $ "Missing " <> name) <$> lookupEnv (unpack name)
 120     pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
 121
 122 optSetting :: FromHttpApiData a => Text -> a -> IO a
 123 optSetting name d = do
 124     me <- lookupEnv (unpack name)
 125     case me of
 126         Nothing -> pure d
 127         Just e -> pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
 128
 129 --settingsFromEnvironment :: IO Settings
 130 --settingsFromEnvironment =
 131 --    Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
 132 --             <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
 133 --             <*> optSetting "PORT" 3000
 134 --             <*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn")
 135 --             <*> reqSetting "DB_SERVER"
 136 --             <*> (parseJwk <$> reqSetting "JWT_SECRET")
 137 --             <*> optSetting "SEND_EMAIL" SendEmailViaAws
 138
 139 data FireWall = FireWall { unFireWall :: Bool }
 140
 141 data Env = Env
 142   { _env_settings :: !Settings
 143   , _env_logger   :: !LoggerSet
 144   , _env_conn     :: !Connection
 145   , _env_repo     :: !RepoEnv
 146   , _env_manager  :: !Manager
 147   , _env_self_url :: !BaseUrl
 148   , _env_scrapers :: !ScrapersEnv
 149   }
 150   deriving (Generic)
 151
 152 makeLenses ''Env
 153
 154 instance HasConnection Env where
 155   connection = env_conn
 156
 157 instance HasRepoVar Env where
 158   repoVar = repoEnv . repoVar
 159
 160 instance HasRepoSaver Env where
 161   repoSaver = repoEnv . repoSaver
 162
 163 instance HasRepo Env where
 164   repoEnv = env_repo
 165
 166 instance HasSettings Env where
 167   settings = env_settings
 168
 169 instance Servant.Job.Core.HasEnv Env (Job ScraperStatus ScraperStatus) where
 170   _env = env_scrapers . Servant.Job.Core._env
 171
 172 instance HasJobEnv Env ScraperStatus ScraperStatus where
 173   job_env = env_scrapers
 174
 175 data MockEnv = MockEnv
 176   { _menv_firewall :: !FireWall
 177   }
 178   deriving (Generic)
 179
 180 makeLenses ''MockEnv
 181
 182 -- | TODO add this path in Settings
 183
 184 repoDir :: FilePath
 185 repoDir = "repos"
 186
 187 repoSnapshot :: FilePath
 188 repoSnapshot = repoDir <> "/repo.json"
 189
 190 -- | TODO add hard coded file in Settings
 191 -- This assumes we own the lock on repoSnapshot.
 192 repoSaverAction :: ToJSON a => a -> IO ()
 193 repoSaverAction a = do
 194   withTempFile "repos" "tmp-repo.json" $ \fp h -> do
 195     -- printDebug "repoSaverAction" fp
 196     L.hPut h $ encode a
 197     hClose h
 198     renameFile fp repoSnapshot
 199
 200 mkRepoSaver :: MVar NgramsRepo -> IO (IO ())
 201 mkRepoSaver repo_var = mkDebounce settings
 202   where
 203     settings = defaultDebounceSettings
 204                  { debounceFreq   = 1000000 -- 1 second
 205                  , debounceAction = withMVar repo_var repoSaverAction
 206                    -- Here this not only `readMVar` but `takeMVar`.
 207                    -- Namely while repoSaverAction is saving no other change
 208                    -- can be made to the MVar.
 209                    -- This might be not efficent and thus reconsidered later.
 210                    -- However this enables to safely perform a *final* save.
 211                    -- See `cleanEnv`.
 212                    -- Future work:
 213                    -- Add a new MVar just for saving.
 214                  }
 215
 216 readRepoEnv :: IO RepoEnv
 217 readRepoEnv = do
 218   -- Does file exist ? :: Bool
 219   _repoDir <- createDirectoryIfMissing True repoDir
 220
 221   repoFile <- doesFileExist repoSnapshot
 222
 223   -- Is file not empty ? :: Bool
 224   repoExists <- if repoFile
 225              then (>0) <$> getFileSize repoSnapshot
 226              else pure False
 227
 228   mlock <- tryLockFile repoSnapshot Exclusive
 229   lock <- maybe (panic "Repo file already locked") pure mlock
 230
 231   mvar <- newMVar =<<
 232     if repoExists
 233       then do
 234         e_repo <- eitherDecodeFileStrict repoSnapshot
 235         repo   <- either fail pure e_repo
 236         let archive = repoSnapshot <> ".v" <> show (repo ^. r_version)
 237         copyFile repoSnapshot archive
 238         pure repo
 239       else
 240         pure initRepo
 241   -- TODO save in DB here
 242   saver <- mkRepoSaver mvar
 243   pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
 244
 245 devJwkFile :: FilePath
 246 devJwkFile = "dev.jwk"
 247
 248 newEnv :: PortNumber -> FilePath -> IO Env
 249 newEnv port file = do
 250   manager <- newTlsManager
 251   settings <- devSettings devJwkFile <&> appPort .~ port -- TODO read from 'file'
 252   when (port /= settings ^. appPort) $
 253     panic "TODO: conflicting settings of port"
 254
 255   self_url <- parseBaseUrl $ "http://0.0.0.0:" <> show port
 256   param    <- databaseParameters file
 257   conn     <- connect param
 258   repo     <- readRepoEnv
 259   scrapers_env <- newJobEnv defaultSettings manager
 260   logger <- newStderrLoggerSet defaultBufSize
 261
 262   pure $ Env
 263     { _env_settings   = settings
 264     , _env_logger     = logger
 265     , _env_conn       = conn
 266     , _env_repo       = repo
 267     , _env_manager    = manager
 268     , _env_scrapers   = scrapers_env
 269     , _env_self_url   = self_url
 270     }
 271
 272 data DevEnv = DevEnv
 273   { _dev_env_conn :: !Connection
 274   , _dev_env_repo :: !RepoEnv
 275   , _dev_env_settings :: !Settings
 276   }
 277
 278 makeLenses ''DevEnv
 279
 280 instance HasConnection DevEnv where
 281   connection = dev_env_conn
 282
 283 instance HasRepoVar DevEnv where
 284   repoVar = repoEnv . repoVar
 285
 286 instance HasRepoSaver DevEnv where
 287   repoSaver = repoEnv . repoSaver
 288
 289 instance HasRepo DevEnv where
 290   repoEnv = dev_env_repo
 291
 292 instance HasSettings DevEnv where
 293   settings = dev_env_settings
 294
 295 cleanEnv :: HasRepo env => env -> IO ()
 296 cleanEnv env = do
 297   r <- takeMVar (env ^. repoEnv . renv_var)
 298   repoSaverAction r
 299   unlockFile (env ^. repoEnv . renv_lock)
 300
 301 withDevEnv :: FilePath -> (DevEnv -> IO a) -> IO a
 302 withDevEnv iniPath k = do
 303   env <- newDevEnv
 304   k env `finally` cleanEnv env
 305
 306   where
 307     newDevEnv = do
 308       param <- databaseParameters iniPath
 309       conn  <- connect param
 310       repo  <- readRepoEnv
 311       setts <- devSettings devJwkFile
 312       pure $ DevEnv
 313         { _dev_env_conn = conn
 314         , _dev_env_repo = repo
 315         , _dev_env_settings = setts
 316         }
 317
 318 -- | Run Cmd Sugar for the Repl (GHCI)
 319 runCmdRepl :: Show err => Cmd' DevEnv err a -> IO a
 320 runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
 321
 322 runCmdReplServantErr :: Cmd' DevEnv ServerError a -> IO a
 323 runCmdReplServantErr = runCmdRepl
 324
 325 -- Use only for dev
 326 -- In particular this writes the repo file after running
 327 -- the command.
 328 -- This function is constrained to the DevEnv rather than
 329 -- using HasConnection and HasRepoVar.
 330 runCmdDev :: Show err => DevEnv -> Cmd' DevEnv err a -> IO a
 331 runCmdDev env f =
 332   (either (fail . show) pure =<< runCmd env f)
 333     `finally`
 334   runReaderT saveRepo env
 335
 336 -- Use only for dev
 337 runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
 338 runCmdDevNoErr = runCmdDev
 339
 340 -- Use only for dev
 341 runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
 342 runCmdDevServantErr = runCmdDev