Successful first servant client test

bin/gargantext-server/Main.hs

@@ -53,19 +53,6 @@ data MyOptions w =
 instance ParseRecord (MyOptions Wrapped)
 deriving instance Show (MyOptions Unwrapped)
 
--- | A plain logger in the IO monad, waiting for more serious logging solutions like
--- the one described in https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/229
-instance HasLogger IO where
-  data instance Logger IO        = IOLogger
-  type instance LogInitParams IO = ()
-  type instance LogPayload IO    = String
-  initLogger                     = \() -> pure IOLogger
-  destroyLogger                  = \_  -> pure ()
-  logMsg = \IOLogger lvl msg ->
-    let pfx = "[" <> show lvl <> "] "
-    in putStrLn $ pfx <> msg
-  logTxt lgr lvl msg = logMsg lgr lvl (unpack msg)
-
 main :: IO ()
 main = withLogger () $ \ioLogger -> do
   MyOptions myMode myPort myIniFile myVersion  <- unwrapRecord

gargantext.cabal

@@ -956,8 +956,11 @@ test-suite garg-test-tasty
     , raw-strings-qq
     , recover-rtti >= 0.4 && < 0.5
     , resource-pool >= 0.2.3.2 && < 0.2.4
+    , servant-auth
+    , servant-auth-client
     , servant-client
     , servant-job
+    , servant-server
     , shelly >= 1.9 && < 2
     , stm ^>= 2.5.0.1
     , tasty ^>= 1.4.2.1
@@ -1045,8 +1048,11 @@ test-suite garg-test-hspec
     , raw-strings-qq
     , recover-rtti >= 0.4 && < 0.5
     , resource-pool >= 0.2.3.2 && < 0.2.4
+    , servant-auth
+    , servant-auth-client
     , servant-client
     , servant-job
+    , servant-server
     , shelly >= 1.9 && < 2
     , stm ^>= 2.5.0.1
     , tasty ^>= 1.4.2.1

src/Gargantext/API/Admin/Settings.hs

@@ -184,8 +184,8 @@ newEnv logger port file = do
   when (port /= settings' ^. appPort) $
     panic "TODO: conflicting settings of port"
 
-  !config_env    <- readConfig file
-  prios         <- Jobs.readPrios (file <> ".jobs")
+  !config_env   <- readConfig file
+  prios         <- withLogger () $ \ioLogger -> Jobs.readPrios ioLogger (file <> ".jobs")
   let prios' = Jobs.applyPrios prios Jobs.defaultPrios
   putStrLn $ "Overrides: " <> show prios
   putStrLn $ "New priorities: " <> show prios'

src/Gargantext/API/Routes.hs

@@ -57,12 +57,14 @@ import qualified Gargantext.API.Node.Document.Export.Types as DocumentExport
 import qualified Gargantext.API.Public                     as Public
 
 
-type GargAPI = "api" :> Summary "API " :> GargAPIVersion
+type GargAPI = MkGargAPI (GargAPIVersion GargAPI')
+
+type MkGargAPI sub = "api" :> Summary "API " :> GargAPIVersion sub
 --- | TODO          :<|> Summary "Latest API" :> GargAPI'
 
-type GargAPIVersion = "v1.0"
-                   :> Summary "Garg API Version "
-                   :> GargAPI'
+type GargAPIVersion sub = "v1.0"
+                        :> Summary "Garg API Version "
+                        :> sub
 
 type GargVersion = "version"
                  :> Summary "Backend version"

src/Gargantext/System/Logging.hs

 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies    #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Gargantext.System.Logging (
     LogLevel(..)
@@ -7,6 +8,7 @@ module Gargantext.System.Logging (
   , MonadLogger(..)
   , logM
   , logLocM
+  , logLoc
   , withLogger
   , withLoggerHoisted
   ) where
@@ -73,6 +75,12 @@ logLocM = [| \level msg ->
   in logM level (formatWithLoc loc msg)
   |]
 
+logLoc :: ExpQ
+logLoc = [| \logger level msg ->
+  let loc = $(getLocTH)
+  in logTxt logger level (formatWithLoc loc msg)
+  |]
+
 formatWithLoc :: Loc -> T.Text -> T.Text
 formatWithLoc loc msg = "[" <> locationToText <> "] " <> msg
   where
@@ -109,3 +117,16 @@ withLoggerHoisted :: (MonadBaseControl IO m, HasLogger m)
                   -> (Logger m -> IO a)
                   -> IO a
 withLoggerHoisted params act = bracket (initLogger params) destroyLogger act
+
+-- | A plain logger in the IO monad, waiting for more serious logging solutions like
+-- the one described in https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/229
+instance HasLogger IO where
+  data instance Logger IO        = IOLogger
+  type instance LogInitParams IO = ()
+  type instance LogPayload IO    = String
+  initLogger                     = \() -> pure IOLogger
+  destroyLogger                  = \_  -> pure ()
+  logMsg = \IOLogger lvl msg ->
+    let pfx = "[" <> show lvl <> "] "
+    in putStrLn $ pfx <> msg
+  logTxt lgr lvl msg = logMsg lgr lvl (T.unpack msg)

src/Gargantext/Utils/Jobs.hs

+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 module Gargantext.Utils.Jobs (
   -- * Serving the JOBS API
@@ -14,11 +15,13 @@ import Data.Aeson (ToJSON)
 import Prelude
 import System.Directory (doesFileExist)
 import Text.Read (readMaybe)
+import qualified Data.Text as T
 
 import Gargantext.API.Admin.EnvTypes
 import Gargantext.API.Prelude
 import qualified Gargantext.Utils.Jobs.Internal as Internal
 import Gargantext.Utils.Jobs.Monad
+import Gargantext.System.Logging
 
 import qualified Servant.Job.Async as SJ
 
@@ -75,12 +78,11 @@ parsePrios (x : xs) = (:) <$> go x <*> parsePrios xs
             | otherwise                  -> error $
               "parsePrios: invalid input. " ++ show (prop, valS)
 
-readPrios :: FilePath -> IO [(GargJob, Int)]
-readPrios fp = do
+readPrios :: Logger IO -> FilePath -> IO [(GargJob, Int)]
+readPrios logger fp = do
   exists <- doesFileExist fp
   case exists of
     False -> do
-      putStrLn $
-        "Warning: " ++ fp ++ " doesn't exist, using default job priorities."
+      $(logLoc) logger WARNING $ T.pack $ fp ++ " doesn't exist, using default job priorities."
       pure []
     True -> parsePrios . lines =<< readFile fp

test-data/test_config.ini

@@ -21,3 +21,15 @@ PUBMED_API_KEY = "no_key"
 EN = corenlp://localhost:9000
 FR = spacy://localhost:8001
 All = corenlp://localhost:9000
+
+[database]
+DB_HOST = 127.0.0.1
+
+[mail]
+MAIL_PORT = 25
+MAIL_HOST = localhost
+MAIL_USER = gargantext
+MAIL_PASSWORD =
+MAIL_FROM     =
+# NoAuth | Normal | SSL | TLS | STARTTLS
+MAIL_LOGIN_TYPE = Normal

test/Test/API/Authentication.hs

 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE BangPatterns #-}
 
 module Test.API.Authentication where
 
 import Prelude
-import Control.Concurrent.MVar
 import Data.Proxy
 import Gargantext.API (makeApp)
-import Gargantext.API.Admin.EnvTypes (Mode(Mock))
-import Gargantext.API.Admin.Settings (newEnv)
+import Gargantext.API.Admin.EnvTypes (Mode(Mock), Env (..))
+import Gargantext.API.Admin.Settings
 import Gargantext.API.Routes
 import Gargantext.System.Logging
 import Network.HTTP.Client hiding (Proxy)
 import Servant.Client
-import Test.Database.Setup (withTestDB, fakeIniPath)
+import Test.Database.Setup (withTestDB, fakeIniPath, testEnvToPgConnectionInfo)
 import Test.Hspec
 import qualified Network.Wai.Handler.Warp         as Warp
 import Test.Database.Types
+import Gargantext.API.Prelude
+import qualified Gargantext.Utils.Jobs as Jobs
+import qualified Gargantext.Utils.Jobs.Queue as Jobs
+import qualified Gargantext.Utils.Jobs.Settings as Jobs
+import qualified Gargantext.Utils.Jobs.Monad as Jobs
+import qualified Gargantext.Prelude.Mail as Mail
+import qualified Gargantext.Prelude.NLP as NLP
+import Network.HTTP.Client.TLS (newTlsManager)
+import Control.Lens
+import Gargantext.API.Admin.Types
+import Gargantext.Prelude.Config
+import Gargantext.Core.NodeStory
+import Gargantext.Database.Prelude
+import Gargantext.Core.NLP
+import qualified Servant.Job.Async as ServantAsync
+import Servant.Auth.Client ()
 
-withGargApp :: (Warp.Port -> IO ()) -> IO ()
-withGargApp action = do
-  randomPort <- newEmptyMVar
+newTestEnv :: TestEnv -> Logger (GargM Env GargError) -> Warp.Port -> IO Env
+newTestEnv testEnv logger port = do
+  file          <- fakeIniPath
+  !manager_env  <- newTlsManager
+  !settings'    <- devSettings devJwkFile <&> appPort .~ port
+
+  !config_env    <- readConfig file
+  prios          <- withLogger () $ \ioLogger -> Jobs.readPrios ioLogger (file <> ".jobs")
+  let prios' = Jobs.applyPrios prios Jobs.defaultPrios
+  !self_url_env  <- parseBaseUrl $ "http://0.0.0.0:" <> show port
+  dbParam        <- pure $ testEnvToPgConnectionInfo testEnv
+  !pool          <- newPool dbParam
+
+  !nodeStory_env <- readNodeStoryEnv pool
+  !scrapers_env  <- ServantAsync.newJobEnv ServantAsync.defaultSettings manager_env
+
+  secret        <- Jobs.genSecret
+  let jobs_settings = (Jobs.defaultJobSettings 1 secret)
+                        & Jobs.l_jsJobTimeout .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_job_timeout)
+                        & Jobs.l_jsIDTimeout  .~ (fromIntegral $ config_env ^. hasConfig ^. gc_js_id_timeout)
+  !jobs_env     <- Jobs.newJobEnv jobs_settings prios' manager_env
+  !config_mail  <- Mail.readConfig file
+  !nlp_env      <- nlpServerMap <$> NLP.readConfig file
+
+  pure $ Env
+    { _env_settings  = settings'
+    , _env_logger    = logger
+    , _env_pool      = pool
+    , _env_nodeStory = nodeStory_env
+    , _env_manager   = manager_env
+    , _env_scrapers  = scrapers_env
+    , _env_jobs      = jobs_env
+    , _env_self_url  = self_url_env
+    , _env_config    = config_env
+    , _env_mail      = config_mail
+    , _env_nlp       = nlp_env
+    }
+
+withGargApp :: TestEnv -> (Warp.Port -> IO ()) -> IO ()
+withGargApp testEnv action = do
   let createApp = do
-        port <- readMVar randomPort
         withLoggerHoisted Mock $ \ioLogger -> do
-          ini <- fakeIniPath
-          env <- newEnv ioLogger port ini
+          env <- newTestEnv testEnv ioLogger 8080
           makeApp env
-  Warp.testWithApplication createApp (\p -> putMVar randomPort p >> action p)
+  Warp.testWithApplication createApp action
 
 withTestDBAndPort :: ((TestEnv, Warp.Port) -> IO ()) -> IO ()
 withTestDBAndPort action =
   withTestDB $ \testEnv ->
-    withGargApp $ \port ->
+    withGargApp testEnv $ \port ->
       action (testEnv, port)
 
 tests :: Spec
 tests = sequential $ aroundAll withTestDBAndPort $ do
   describe "Authentication" $ do
-    let getVersion = client (Proxy :: Proxy GargVersion)
+    let version_api = client (Proxy :: Proxy (MkGargAPI (GargAPIVersion GargVersion)))
     baseUrl <- runIO $ parseBaseUrl "http://localhost"
     manager <- runIO $ newManager defaultManagerSettings
     let clientEnv port = mkClientEnv manager (baseUrl { baseUrlPort = port })
@@ -47,5 +98,5 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
     -- testing scenarios start here
     describe "GET /version" $ do
       it "requires no auth" $ \(_testEnv, port) -> do
-        result <- runClientM getVersion (clientEnv port)
-        result `shouldBe` (Right "foo")
+        result <- runClientM version_api (clientEnv port)
+        result `shouldBe` (Right "0.0.6.9.9.7.7")

test/Test/Database/Setup.hs

 {-# LANGUAGE TupleSections #-}
 module Test.Database.Setup (
-  withTestDB
+    withTestDB
   , fakeIniPath
+  , testEnvToPgConnectionInfo
   ) where
 
 import Control.Exception hiding (assert)
 import Control.Monad
+import Data.Maybe (fromMaybe)
+import Data.Monoid
 import Data.Pool hiding (withResource)
 import Data.String
 import Gargantext.Prelude.Config
@@ -17,6 +20,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import qualified Database.PostgreSQL.Simple as PG
 import qualified Database.PostgreSQL.Simple.Options as Client
+import qualified Database.PostgreSQL.Simple.Options as Opts
 import qualified Database.Postgres.Temp as Tmp
 import qualified Shelly as SH
 
@@ -73,3 +77,16 @@ setup = do
 
 withTestDB :: (TestEnv -> IO ()) -> IO ()
 withTestDB = bracket setup teardown
+
+testEnvToPgConnectionInfo :: TestEnv -> PG.ConnectInfo
+testEnvToPgConnectionInfo TestEnv{..} =
+  PG.ConnectInfo { PG.connectHost     = "0.0.0.0"
+                 , PG.connectPort     = fromIntegral $ fromMaybe 5432
+                                                     $ getLast
+                                                     $ Opts.port
+                                                     $ Tmp.toConnectionOptions
+                                                     $ _DBTmp test_db
+                 , PG.connectUser     = dbUser
+                 , PG.connectPassword = dbPassword
+                 , PG.connectDatabase = dbName
+                 }

test/drivers/hspec/Main.hs

@@ -42,5 +42,5 @@ main :: IO ()
 main = do
   hSetBuffering stdout NoBuffering
   bracket startCoreNLPServer stopCoreNLPServer $ \_ -> hspec $ do
-    DB.tests
     API.tests
+    DB.tests