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