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
  11 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  12
  13 {-# LANGUAGE DataKinds           #-}
  14 {-# LANGUAGE DeriveGeneric       #-}
  15 {-# LANGUAGE FlexibleContexts    #-}
  16 {-# LANGUAGE FlexibleInstances   #-}
  17 {-# LANGUAGE NoImplicitPrelude   #-}
  18 {-# LANGUAGE OverloadedStrings   #-}
  19 {-# LANGUAGE RankNTypes          #-}
  20 {-# LANGUAGE ScopedTypeVariables #-}
  21 {-# LANGUAGE TemplateHaskell     #-}
  22
  23 module Gargantext.API.Settings
  24     where
  25
  26 import System.Directory
  27 import System.Log.FastLogger
  28 import GHC.Enum
  29 import GHC.Generics (Generic)
  30 import Prelude (Bounded(), fail)
  31 import System.Environment (lookupEnv)
  32 import System.IO (FilePath, hClose)
  33 import System.IO.Temp (withTempFile)
  34 import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
  35 import Database.PostgreSQL.Simple (Connection, connect)
  36 import Network.HTTP.Client (Manager)
  37 import Network.HTTP.Client.TLS (newTlsManager)
  38
  39 import Data.Aeson
  40 import Data.Maybe (fromMaybe)
  41 import Data.Either (either)
  42 import Data.Text
  43 import Data.Text.Encoding (encodeUtf8)
  44 import Data.ByteString (ByteString)
  45 import qualified Data.ByteString.Lazy as L
  46
  47 import Servant
  48 import Servant.Client (BaseUrl, parseBaseUrl)
  49 import Servant.Job.Async (newJobEnv, defaultSettings)
  50 import Web.HttpApiData (parseUrlPiece)
  51 import qualified Jose.Jwk as Jose
  52 import qualified Jose.Jwa as Jose
  53
  54 import Control.Concurrent
  55 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
  56 import Control.Exception (finally)
  57 import Control.Monad.Logger
  58 import Control.Monad.Reader
  59 import Control.Lens
  60 import Gargantext.Prelude
  61 import Gargantext.Database.Utils (databaseParameters, HasConnection(..), Cmd', runCmd)
  62 import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..), r_version, saveRepo, initRepo, renv_var, renv_lock)
  63 import Gargantext.API.Orchestrator.Types
  64
  65 type PortNumber = Int
  66
  67 data SendEmailType = SendEmailViaAws
  68                    | LogEmailToConsole
  69                    | WriteEmailToFile
  70     deriving (Show, Read, Enum, Bounded, Generic)
  71
  72
  73 data Settings = Settings
  74     { _allowedOrigin   :: ByteString   -- allowed origin for CORS
  75     , _allowedHost     :: ByteString   -- allowed host for CORS
  76     , _appPort         :: PortNumber
  77     , _logLevelLimit   :: LogLevel -- log level from the monad-logger package
  78 --    , _dbServer        :: Text
  79 --    ^ this is not used yet
  80     , _jwtSecret       :: Jose.Jwk -- key from the jose-jwt package
  81     , _sendLoginEmails :: SendEmailType
  82     , _scrapydUrl      :: BaseUrl
  83     , _fileFolder      :: FilePath
  84     }
  85
  86 makeLenses ''Settings
  87
  88 class HasSettings env where
  89   settings :: Getter env Settings
  90
  91
  92 parseJwk :: Text -> Jose.Jwk
  93 parseJwk secretStr = jwk
  94     where
  95         secretBs = encodeUtf8 secretStr
  96         jwk      = Jose.SymmetricJwk secretBs
  97                                      Nothing
  98                                      Nothing
  99                                      (Just $ Jose.Signed Jose.HS256)
 100
 101 devSettings :: Settings
 102 devSettings = Settings
 103     { _allowedOrigin = "http://localhost:8008"
 104     , _allowedHost = "localhost:3000"
 105     , _appPort = 3000
 106     , _logLevelLimit = LevelDebug
 107 --    , _dbServer = "localhost"
 108     -- generate with dd if=/dev/urandom bs=1 count=32 | base64
 109     -- make sure jwtSecret differs between development and production, because you do not want
 110     -- your production key inside source control.
 111     , _jwtSecret = parseJwk "MVg0YAPVSPiYQc/qIs/rV/X32EFR0zOJWfHFgMbszMw="
 112     , _sendLoginEmails = LogEmailToConsole
 113     , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
 114     , _fileFolder = "data"
 115     }
 116
 117
 118
 119 reqSetting :: FromHttpApiData a => Text -> IO a
 120 reqSetting name = do
 121     e <- fromMaybe (panic $ "Missing " <> name) <$> lookupEnv (unpack name)
 122     pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
 123
 124 optSetting :: FromHttpApiData a => Text -> a -> IO a
 125 optSetting name d = do
 126     me <- lookupEnv (unpack name)
 127     case me of
 128         Nothing -> pure d
 129         Just e -> pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
 130
 131 --settingsFromEnvironment :: IO Settings
 132 --settingsFromEnvironment =
 133 --    Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
 134 --             <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
 135 --             <*> optSetting "PORT" 3000
 136 --             <*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn")
 137 --             <*> reqSetting "DB_SERVER"
 138 --             <*> (parseJwk <$> reqSetting "JWT_SECRET")
 139 --             <*> optSetting "SEND_EMAIL" SendEmailViaAws
 140
 141 data FireWall = FireWall { unFireWall :: Bool }
 142
 143 data Env = Env
 144   { _env_settings :: !Settings
 145   , _env_logger   :: !LoggerSet
 146   , _env_conn     :: !Connection
 147   , _env_repo     :: !RepoEnv
 148   , _env_manager  :: !Manager
 149   , _env_self_url :: !BaseUrl
 150   , _env_scrapers :: !ScrapersEnv
 151   }
 152   deriving (Generic)
 153
 154 makeLenses ''Env
 155
 156 instance HasConnection Env where
 157   connection = env_conn
 158
 159 instance HasRepoVar Env where
 160   repoVar = repoEnv . repoVar
 161
 162 instance HasRepoSaver Env where
 163   repoSaver = repoEnv . repoSaver
 164
 165 instance HasRepo Env where
 166   repoEnv = env_repo
 167
 168 instance HasSettings Env where
 169   settings = env_settings
 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 newEnv :: PortNumber -> FilePath -> IO Env
 236 newEnv port file = do
 237   manager <- newTlsManager
 238   settings <- pure (devSettings & appPort .~ port) -- TODO read from 'file'
 239   when (port /= settings ^. appPort) $
 240     panic "TODO: conflicting settings of port"
 241
 242   self_url <- parseBaseUrl $ "http://0.0.0.0:" <> show port
 243   param    <- databaseParameters file
 244   conn     <- connect param
 245   repo     <- readRepoEnv
 246   scrapers_env <- newJobEnv defaultSettings manager
 247   logger <- newStderrLoggerSet defaultBufSize
 248
 249   pure $ Env
 250     { _env_settings   = settings
 251     , _env_logger     = logger
 252     , _env_conn       = conn
 253     , _env_repo       = repo
 254     , _env_manager    = manager
 255     , _env_scrapers   = scrapers_env
 256     , _env_self_url   = self_url
 257     }
 258
 259 data DevEnv = DevEnv
 260   { _dev_env_conn :: !Connection
 261   , _dev_env_repo :: !RepoEnv
 262   , _dev_env_settings :: !Settings
 263   }
 264
 265 makeLenses ''DevEnv
 266
 267 instance HasConnection DevEnv where
 268   connection = dev_env_conn
 269
 270 instance HasRepoVar DevEnv where
 271   repoVar = repoEnv . repoVar
 272
 273 instance HasRepoSaver DevEnv where
 274   repoSaver = repoEnv . repoSaver
 275
 276 instance HasRepo DevEnv where
 277   repoEnv = dev_env_repo
 278
 279 instance HasSettings DevEnv where
 280   settings = dev_env_settings
 281
 282 cleanEnv :: HasRepo env => env -> IO ()
 283 cleanEnv env = do
 284   r <- takeMVar (env ^. repoEnv . renv_var)
 285   repoSaverAction r
 286   unlockFile (env ^. repoEnv . renv_lock)
 287
 288 withDevEnv :: FilePath -> (DevEnv -> IO a) -> IO a
 289 withDevEnv iniPath k = do
 290   env <- newDevEnv
 291   k env `finally` cleanEnv env
 292
 293   where
 294     newDevEnv = do
 295       param <- databaseParameters iniPath
 296       conn  <- connect param
 297       repo  <- readRepoEnv
 298       pure $ DevEnv
 299         { _dev_env_conn = conn
 300         , _dev_env_repo = repo
 301         , _dev_env_settings = devSettings
 302         }
 303
 304 -- | Run Cmd Sugar for the Repl (GHCI)
 305 runCmdRepl :: Show err => Cmd' DevEnv err a -> IO a
 306 runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
 307
 308 runCmdReplServantErr :: Cmd' DevEnv ServantErr a -> IO a
 309 runCmdReplServantErr = runCmdRepl
 310
 311 -- Use only for dev
 312 -- In particular this writes the repo file after running
 313 -- the command.
 314 -- This function is constrained to the DevEnv rather than
 315 -- using HasConnection and HasRepoVar.
 316 runCmdDev :: Show err => DevEnv -> Cmd' DevEnv err a -> IO a
 317 runCmdDev env f =
 318   (either (fail . show) pure =<< runCmd env f)
 319     `finally`
 320   runReaderT saveRepo env
 321
 322 -- Use only for dev
 323 runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
 324 runCmdDevNoErr = runCmdDev
 325
 326 -- Use only for dev
 327 runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServantErr a -> IO a
 328 runCmdDevServantErr = runCmdDev