]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Settings.hs
Secure API with JWT auth. Part 1
[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 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