Refactoring to have minimum dependencies on concrete env types

bin/gargantext-admin/Main.hs

@@ -15,13 +15,13 @@ Portability : POSIX
 
 module Main where
 
-import Gargantext.API.Admin.Settings (withDevEnv, runCmdDev)
+import Gargantext.API.Dev (withDevEnv, runCmdDev)
 import Gargantext.API.Prelude (GargError)
 import Gargantext.Database.Action.User.New (newUsers)
 import Gargantext.Database.Prelude (Cmd'')
 import Gargantext.Prelude
 import System.Environment (getArgs)
-import Gargantext.API.Admin.Types (DevEnv)
+import Gargantext.API.Admin.EnvTypes (DevEnv)
 
 main :: IO ()
 main = do

bin/gargantext-import/Main.hs

@@ -22,8 +22,8 @@ import Prelude (read)
 import System.Environment (getArgs)
 import qualified Data.Text as Text
 
-import Gargantext.API.Admin.Settings (withDevEnv, runCmdDev)
-import Gargantext.API.Admin.Types (DevEnv(..))
+import Gargantext.API.Dev (withDevEnv, runCmdDev)
+import Gargantext.API.Admin.EnvTypes (DevEnv(..))
 import Gargantext.API.Node () -- instances
 import Gargantext.API.Prelude (GargError)
 import Gargantext.Core (Lang(..))

bin/gargantext-init/Main.hs

@@ -17,7 +17,7 @@ module Main where
 
 import Data.Text (Text)
 import Data.Either (Either(..))
-import Gargantext.API.Admin.Settings (withDevEnv, runCmdDev)
+import Gargantext.API.Dev (withDevEnv, runCmdDev)
 import Gargantext.API.Prelude (GargError)
 import Gargantext.API.Node () -- instances only
 import Gargantext.Core.Types.Individu (User(..))

bin/gargantext-upgrade/Main.hs

@@ -15,7 +15,7 @@ Import a corpus binary.
 
 module Main where
 
-import Gargantext.API.Admin.Settings (withDevEnv, runCmdDev)
+import Gargantext.API.Dev (withDevEnv, runCmdDev)
 import Gargantext.API.Prelude (GargError)
 import Gargantext.API.Node () -- instances only
 import Gargantext.Database.Admin.Types.Node

package.yaml

@@ -45,6 +45,7 @@ library:
   - Gargantext.API.Ngrams
   - Gargantext.API.Ngrams.Types
   - Gargantext.API.Admin.Settings
+  - Gargantext.API.Admin.EnvTypes
   - Gargantext.API.Admin.Types
   - Gargantext.API.Prelude
   - Gargantext.Core

src/Gargantext/API/Admin/EnvTypes.hs

+-- |
+
+{-# LANGUAGE TemplateHaskell     #-}
+
+module Gargantext.API.Admin.EnvTypes where
+
+import Control.Lens
+import Data.Pool (Pool)
+import Database.PostgreSQL.Simple (Connection)
+import GHC.Generics (Generic)
+import Network.HTTP.Client (Manager)
+import Servant.Client (BaseUrl)
+import Servant.Job.Async (HasJobEnv(..), Job)
+import System.Log.FastLogger
+import qualified Servant.Job.Core
+
+import Gargantext.API.Admin.Types
+import Gargantext.API.Admin.Orchestrator.Types
+import Gargantext.API.Ngrams.Types (HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..))
+import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
+import Gargantext.Prelude
+import Gargantext.Prelude.Config (GargConfig(..))
+
+
+data Env = Env
+  { _env_settings :: !Settings
+  , _env_logger   :: !LoggerSet
+  , _env_pool     :: !(Pool Connection)
+  , _env_repo     :: !RepoEnv
+  , _env_manager  :: !Manager
+  , _env_self_url :: !BaseUrl
+  , _env_scrapers :: !ScrapersEnv
+  , _env_config   :: !GargConfig
+  }
+  deriving (Generic)
+
+makeLenses ''Env
+
+instance HasConfig Env where
+  config = env_config
+
+instance HasConnectionPool Env where
+  connPool = env_pool
+
+instance HasRepoVar Env where
+  repoVar = repoEnv . repoVar
+
+instance HasRepoSaver Env where
+  repoSaver = repoEnv . repoSaver
+
+instance HasRepo Env where
+  repoEnv = env_repo
+
+instance HasSettings Env where
+  settings = env_settings
+
+instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
+  _env = env_scrapers . Servant.Job.Core._env
+
+instance HasJobEnv Env JobLog JobLog where
+  job_env = env_scrapers
+
+data MockEnv = MockEnv
+  { _menv_firewall :: !FireWall
+  }
+  deriving (Generic)
+
+makeLenses ''MockEnv
+
+
+data DevEnv = DevEnv
+  { _dev_env_pool     :: !(Pool Connection)
+  , _dev_env_repo     :: !RepoEnv
+  , _dev_env_settings :: !Settings
+  , _dev_env_config   :: !GargConfig
+  }
+
+makeLenses ''DevEnv
+
+instance HasConfig DevEnv where
+  config = dev_env_config
+
+instance HasConnectionPool DevEnv where
+  connPool = dev_env_pool
+
+instance HasRepoVar DevEnv where
+  repoVar = repoEnv . repoVar
+
+instance HasRepoSaver DevEnv where
+  repoSaver = repoEnv . repoSaver
+
+instance HasRepo DevEnv where
+  repoEnv = dev_env_repo
+
+instance HasSettings DevEnv where
+  settings = dev_env_settings
\ No newline at end of file

src/Gargantext/API/Admin/Orchestrator.hs

@@ -16,17 +16,13 @@ module Gargantext.API.Admin.Orchestrator where
 
 import Control.Lens hiding (elements)
 import Data.Aeson
-import Data.Text
 import Servant
 import Servant.Job.Async
 import Servant.Job.Client
-import Servant.Job.Server
-import Servant.Job.Utils (extendBaseUrl)
 import qualified Data.ByteString.Lazy.Char8 as LBS
 
 import Gargantext.API.Admin.Orchestrator.Scrapy.Schedule
 import Gargantext.API.Admin.Orchestrator.Types
-import Gargantext.API.Admin.Types
 import Gargantext.Prelude
 
 callJobScrapy :: (ToJSON e, FromJSON e, FromJSON o, MonadClientJob m)
@@ -77,10 +73,20 @@ pipeline scrapyurl client_env input log_status = do
 --  use:
 --  * serveJobsAPI instead of simpleServeJobsAPI
 --  * JobFunction  instead of simpleJobFunction
+-- TODO:
+--  * HasSelfUrl or move self_url to settings
+--  * HasScrapers or move scrapers to settings
+--  * EnvC env
+{- NOT USED YET
+import Data.Text
+import Servant.Job.Server
+import Servant.Job.Utils (extendBaseUrl)
+import Gargantext.API.Admin.Types
 scrapyOrchestrator :: Env -> IO (Server (WithCallbacks ScraperAPI))
 scrapyOrchestrator env = do
   apiWithCallbacksServer (Proxy :: Proxy ScraperAPI)
     defaultSettings (extendBaseUrl ("scraper" :: Text) $ env ^. env_self_url)
     (env ^. env_manager) (LogEvent logConsole) $
     simpleServeJobsAPI (env ^. env_scrapers) .
-      simpleJobFunction . pipeline (URL $ env ^. env_settings . scrapydUrl)
+      simpleJobFunction . pipeline (URL $ env ^. settings . scrapydUrl)
+-}
\ No newline at end of file

src/Gargantext/API/Admin/Settings.hs

@@ -21,31 +21,27 @@ module Gargantext.API.Admin.Settings
 import Codec.Serialise (Serialise(), serialise, deserialise)
 import Control.Concurrent
 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
-import Control.Exception (finally)
 import Control.Lens
 import Control.Monad.Logger
 import Control.Monad.Reader
 import Data.Maybe (fromMaybe)
 import Data.Pool (Pool, createPool)
-import Data.Text
 import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
 import Network.HTTP.Client.TLS (newTlsManager)
-import Servant
 import Servant.Auth.Server (defaultJWTSettings, CookieSettings(..), XsrfCookieSettings(..), defaultCookieSettings, defaultXsrfCookieSettings, readKey, writeKey)
 import Servant.Client (parseBaseUrl)
 import Servant.Job.Async (newJobEnv, defaultSettings)
 import System.Directory
-import System.Environment (lookupEnv)
 import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
 import System.IO (FilePath, hClose)
 import System.IO.Temp (withTempFile)
 import System.Log.FastLogger
 import qualified Data.ByteString.Lazy as L
 
+import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Admin.Types
 import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
-import Gargantext.API.Ngrams (saveRepo)
-import Gargantext.Database.Prelude (databaseParameters, Cmd', Cmd'', runCmd, HasConfig(..))
+import Gargantext.Database.Prelude (databaseParameters, HasConfig(..))
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (GargConfig(..), gc_repofilepath, readConfig)
 
@@ -68,7 +64,8 @@ devSettings jwkFile = do
   where
     xsrfCookieSetting = defaultXsrfCookieSettings { xsrfExcludeGet = True }
 
-
+{- NOT USED YET
+import System.Environment (lookupEnv)
 
 reqSetting :: FromHttpApiData a => Text -> IO a
 reqSetting name = do
@@ -82,15 +79,16 @@ optSetting name d = do
         Nothing -> pure d
         Just e -> pure $ either (panic $ "Unable to parse " <> name) identity $ parseUrlPiece $ pack e
 
---settingsFromEnvironment :: IO Settings
---settingsFromEnvironment =
---    Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
---             <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
---             <*> optSetting "PORT" 3000
---             <*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn")
---             <*> reqSetting "DB_SERVER"
---             <*> (parseJwk <$> reqSetting "JWT_SECRET")
---             <*> optSetting "SEND_EMAIL" SendEmailViaAws
+settingsFromEnvironment :: IO Settings
+settingsFromEnvironment =
+    Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
+             <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
+             <*> optSetting "PORT" 3000
+             <*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn")
+             <*> reqSetting "DB_SERVER"
+             <*> (parseJwk <$> reqSetting "JWT_SECRET")
+             <*> optSetting "SEND_EMAIL" SendEmailViaAws
+-}
 
 -----------------------------------------------------------------------
 -- | RepoDir FilePath configuration
@@ -197,48 +195,3 @@ cleanEnv env = do
   unlockFile (env ^. repoEnv . renv_lock)
 
 type IniPath  = FilePath
\ No newline at end of file
-withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
-withDevEnv iniPath k = do
-  env <- newDevEnv
-  k env `finally` cleanEnv env
-
-  where
-    newDevEnv = do
-      config  <- readConfig         iniPath
-      dbParam <- databaseParameters iniPath
-      pool    <- newPool            dbParam
-      repo    <- readRepoEnv        (_gc_repofilepath config)
-      setts   <- devSettings devJwkFile
-      pure $ DevEnv
-        { _dev_env_pool = pool
-        , _dev_env_repo = repo
-        , _dev_env_settings = setts
-        , _dev_env_config   = config
-        }
-
--- | Run Cmd Sugar for the Repl (GHCI)
-
-runCmdRepl :: Show err => Cmd'' DevEnv err a -> IO a
-runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
-
-runCmdReplServantErr :: Cmd'' DevEnv ServerError a -> IO a
-runCmdReplServantErr = runCmdRepl
-
--- Use only for dev
--- In particular this writes the repo file after running
--- the command.
--- This function is constrained to the DevEnv rather than
--- using HasConnectionPool and HasRepoVar.
-runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a
-runCmdDev env f =
-  (either (fail . show) pure =<< runCmd env f)
-    `finally`
-  runReaderT saveRepo env
-
--- Use only for dev
-runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
-runCmdDevNoErr = runCmdDev
-
--- Use only for dev
-runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
-runCmdDevServantErr = runCmdDev

src/Gargantext/API/Admin/Types.hs

@@ -7,22 +7,12 @@ module Gargantext.API.Admin.Types where
 import Control.Lens
 import Control.Monad.Logger
 import Data.ByteString (ByteString)
-import Data.Pool (Pool)
-import Database.PostgreSQL.Simple (Connection)
 import GHC.Enum
 import GHC.Generics (Generic)
-import Network.HTTP.Client (Manager)
 import Servant.Auth.Server (JWTSettings, CookieSettings(..))
 import Servant.Client (BaseUrl)
-import Servant.Job.Async (HasJobEnv(..), Job)
-import System.Log.FastLogger
-import qualified Servant.Job.Core
 
-import Gargantext.API.Admin.Orchestrator.Types
-import Gargantext.API.Ngrams.Types (HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..))
-import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
 import Gargantext.Prelude
-import Gargantext.Prelude.Config (GargConfig(..))
 
 type PortNumber = Int
 
@@ -31,18 +21,17 @@ data SendEmailType = SendEmailViaAws
                    | WriteEmailToFile
     deriving (Show, Read, Enum, Bounded, Generic)
 
-
 data Settings = Settings
-    { _allowedOrigin   :: ByteString   -- allowed origin for CORS
-    , _allowedHost     :: ByteString   -- allowed host for CORS
-    , _appPort         :: PortNumber
-    , _logLevelLimit   :: LogLevel -- log level from the monad-logger package
+    { _allowedOrigin   :: !ByteString   -- allowed origin for CORS
+    , _allowedHost     :: !ByteString   -- allowed host for CORS
+    , _appPort         :: !PortNumber
+    , _logLevelLimit   :: !LogLevel -- log level from the monad-logger package
 --    , _dbServer        :: Text
 --    ^ this is not used yet
-    , _jwtSettings     :: JWTSettings
-    , _cookieSettings  :: CookieSettings
-    , _sendLoginEmails :: SendEmailType
-    , _scrapydUrl      :: BaseUrl
+    , _jwtSettings     :: !JWTSettings
+    , _cookieSettings  :: !CookieSettings
+    , _sendLoginEmails :: !SendEmailType
+    , _scrapydUrl      :: !BaseUrl
     }
 
 makeLenses ''Settings
@@ -50,78 +39,7 @@ makeLenses ''Settings
 class HasSettings env where
   settings :: Getter env Settings
 
+instance HasSettings Settings where
+  settings = identity
 
 data FireWall = FireWall { unFireWall :: Bool }
\ No newline at end of file
-
-data Env = Env
-  { _env_settings :: !Settings
-  , _env_logger   :: !LoggerSet
-  , _env_pool     :: !(Pool Connection)
-  , _env_repo     :: !RepoEnv
-  , _env_manager  :: !Manager
-  , _env_self_url :: !BaseUrl
-  , _env_scrapers :: !ScrapersEnv
-  , _env_config   :: !GargConfig
-  }
-  deriving (Generic)
-
-makeLenses ''Env
-
-instance HasConfig Env where
-  config = env_config
-
-instance HasConnectionPool Env where
-  connPool = env_pool
-
-instance HasRepoVar Env where
-  repoVar = repoEnv . repoVar
-
-instance HasRepoSaver Env where
-  repoSaver = repoEnv . repoSaver
-
-instance HasRepo Env where
-  repoEnv = env_repo
-
-instance HasSettings Env where
-  settings = env_settings
-
-instance Servant.Job.Core.HasEnv Env (Job JobLog JobLog) where
-  _env = env_scrapers . Servant.Job.Core._env
-
-instance HasJobEnv Env JobLog JobLog where
-  job_env = env_scrapers
-
-data MockEnv = MockEnv
-  { _menv_firewall :: !FireWall
-  }
-  deriving (Generic)
-
-makeLenses ''MockEnv
-
-
-data DevEnv = DevEnv
-  { _dev_env_pool     :: !(Pool Connection)
-  , _dev_env_repo     :: !RepoEnv
-  , _dev_env_settings :: !Settings
-  , _dev_env_config   :: !GargConfig
-  }
-
-makeLenses ''DevEnv
-
-instance HasConfig DevEnv where
-  config = dev_env_config
-
-instance HasConnectionPool DevEnv where
-  connPool = dev_env_pool
-
-instance HasRepoVar DevEnv where
-  repoVar = repoEnv . repoVar
-
-instance HasRepoSaver DevEnv where
-  repoSaver = repoEnv . repoSaver
-
-instance HasRepo DevEnv where
-  repoEnv = dev_env_repo
-
-instance HasSettings DevEnv where
-  settings = dev_env_settings

src/Gargantext/API/Dev.hs

 -- |
 
+-- Use only for dev/repl
 module Gargantext.API.Dev where
 
-import Gargantext.API.Admin.Settings
+import Control.Exception (finally)
+import Control.Monad (fail)
+import Control.Monad.Reader (runReaderT)
+import Servant
+
 import Gargantext.API.Prelude
-import Gargantext.API.Admin.Types
+import Gargantext.API.Admin.Settings
+import Gargantext.API.Admin.EnvTypes
+import Gargantext.API.Ngrams (saveRepo)
 import Gargantext.Database.Prelude
 import Gargantext.Prelude
+import Gargantext.Prelude.Config (GargConfig(..), readConfig)
 
 -------------------------------------------------------------------
+
+withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
+withDevEnv iniPath k = do
+  env <- newDevEnv
+  k env `finally` cleanEnv env
+
+  where
+    newDevEnv = do
+      cfg     <- readConfig         iniPath
+      dbParam <- databaseParameters iniPath
+      pool    <- newPool            dbParam
+      repo    <- readRepoEnv        (_gc_repofilepath cfg)
+      setts   <- devSettings devJwkFile
+      pure $ DevEnv
+        { _dev_env_pool = pool
+        , _dev_env_repo = repo
+        , _dev_env_settings = setts
+        , _dev_env_config   = cfg
+        }
+
+-- | Run Cmd Sugar for the Repl (GHCI)
+
+runCmdRepl :: Show err => Cmd'' DevEnv err a -> IO a
+runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
+
+runCmdReplServantErr :: Cmd'' DevEnv ServerError a -> IO a
+runCmdReplServantErr = runCmdRepl
+
+-- In particular this writes the repo file after running
+-- the command.
+-- This function is constrained to the DevEnv rather than
+-- using HasConnectionPool and HasRepoVar.
+runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a
+runCmdDev env f =
+  (either (fail . show) pure =<< runCmd env f)
+    `finally`
+  runReaderT saveRepo env
+
+runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
+runCmdDevNoErr = runCmdDev
+
+runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
+runCmdDevServantErr = runCmdDev
+
 runCmdReplEasy :: Cmd'' DevEnv GargError a -> IO a
 runCmdReplEasy f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
\ No newline at end of file