]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Settings.hs
Merge branch 'dev-phylo' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell-gargantex...
[gargantext.git] / 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