Add client executable to run 'scripts' against a running Garg backend

bin/gargantext-client/Auth.hs

+module Auth where
+
+import Core
+import Options
+
+import Control.Monad.IO.Class
+import Data.Text.Encoding (encodeUtf8)
+import Options.Generic
+import Servant.Client
+import qualified Servant.Auth.Client as SA
+
+import Gargantext.API.Client
+import qualified Gargantext.API.Admin.Auth.Types as Auth
+import qualified Gargantext.Core.Types.Individu  as Auth
+import qualified Gargantext.Database.Admin.Types.Node as Node
+
+-- | Authenticate and use the resulting Token to perform
+--   auth-restricted actions
+withAuthToken
+  :: ClientOpts -- ^ source of user/pass data
+  -> (SA.Token -> Node.NodeId -> ClientM a) -- ^ do something once authenticated
+  -> ClientM a
+withAuthToken opts act
+  -- both user and password CLI arguments passed
+  | Helpful (Just usr) <- user opts
+  , Helpful (Just pw)  <- pass opts = do
+      authRes <- postAuth (Auth.AuthRequest usr (Auth.GargPassword pw))
+      case Auth._authRes_valid authRes of
+        -- authentication failed, this function critically needs it to
+        -- be able to run the action, so we abort
+        Nothing -> problem $
+          "invalid auth response: " ++
+          maybe "" (show . Auth._authInv_message)
+                   (Auth._authRes_inval authRes)
+        -- authentication went through, we can run the action
+        Just (Auth.AuthValid tok tree_id) -> do
+          let tok' = SA.Token (encodeUtf8 tok)
+          whenVerbose opts $ do
+            liftIO . putStrLn $ "[Debug] Authenticated: token=" ++ show tok ++
+                                ", tree_id=" ++ show tree_id
+          act tok' tree_id
+  -- user and/or pass CLI arguments not passed
+  | otherwise =
+      problem "auth-protected actions require --user and --pass"

bin/gargantext-client/Core.hs

+module Core (problem, whenVerbose) where
+
+import Options
+import Options.Generic
+
+import Control.Exception
+import Control.Monad
+import Control.Monad.Catch
+import Servant.Client
+
+newtype GargClientException = GCE String
+instance Show GargClientException where
+  show (GCE s) = "Garg client exception: " ++ s
+
+instance Exception GargClientException
+
+-- | Abort with a message
+problem :: String -> ClientM a
+problem = throwM . GCE
+
+-- | Only run the given computation when the @--verbose@ flag is
+--   passed.
+whenVerbose :: Monad m => ClientOpts -> m () -> m ()
+whenVerbose opts act = when (unHelpful $ verbose opts) act

bin/gargantext-client/Main.hs

+module Main where
+
+import Control.Monad
+import Network.HTTP.Client
+import Options.Generic
+import Servant.Client
+
+import Options
+import Script (script)
+
+main :: IO ()
+main = do
+  -- we parse CLI options
+  opts@(ClientOpts (Helpful uri) _ _ (Helpful verb)) <- getRecord "Gargantext client"
+  mgr <- newManager defaultManagerSettings
+  burl <- parseBaseUrl uri
+  when verb $ do
+    putStrLn $ "[Debug] user: " ++ maybe "<none>" show (unHelpful $ user opts)
+    putStrLn $ "[Debug] backend: " ++ show burl
+  -- we run 'script' from the Script module, reporting potential errors
+  res <- runClientM (script opts) (mkClientEnv mgr burl)
+  case res of
+    Left err -> putStrLn $ "[Client error] " ++ show err
+    Right a  -> print a

bin/gargantext-client/Options.hs

+{-# LANGUAGE TypeOperators #-}
+module Options where
+
+import Options.Generic
+
+-- | Some general options to be specified on the command line.
+data ClientOpts = ClientOpts
+  { url     :: String <?> "URL to gargantext backend"
+  , user    :: Maybe Text <?> "(optional) username for auth-restricted actions"
+  , pass    :: Maybe Text <?> "(optional) password for auth-restricted actions"
+  , verbose :: Bool   <?> "Enable verbose output"
+  } deriving (Generic, Show)
+
+instance ParseRecord ClientOpts

bin/gargantext-client/Script.hs

+module Script (script) where
+
+import Control.Monad.IO.Class
+import Gargantext.API.Client
+import Servant.Client
+
+import Auth
+import Core
+import Options
+import Tracking
+
+-- | An example script. Tweak, rebuild and re-run the executable to see the
+--   effect of your changes. You can hit any gargantext endpoint in the body
+--   of 'script' using the many (many!) client functions exposed by the
+--   'Gargantext.API.Client' module.
+--
+--   Don't forget to pass @--user@ and @--pass@ if you're using 'withAuthToken'.
+script :: ClientOpts -> ClientM ()
+script opts = do
+  -- we start by asking the backend for its version
+  ver <- getBackendVersion
+  liftIO . putStrLn $ "Backend version: " ++ show ver
+
+  -- next we authenticate using the credentials given on the command line
+  -- (through --user and --pass), erroring out loudly if the auth creds don't
+  -- go through, running the continuation otherwise.
+  withAuthToken opts $ \tok userNode -> do
+    liftIO . putStrLn $ "user node: " ++ show userNode
+    steps <-
+      -- we run a few client computations while tracking some EKG metrics
+      -- (any RTS stats or routing-related data), which means that we sample the
+      -- metrics at the beginning, the end, and in between each pair of steps.
+      tracking opts ["rts.gc.bytes_allocated"]
+        [ ("get roots", do
+              roots <- getRoots tok
+              liftIO . putStrLn $ "roots: " ++ show roots
+          )
+        , ("get user node detail", do
+              userNodeDetail <- getNode tok userNode
+              liftIO . putStrLn $ "user node details: " ++ show userNodeDetail
+          )
+        ]
+    -- we pretty print the values we sampled for all metrics and the
+    -- results of all the steps
+    whenVerbose opts (ppTracked steps)

bin/gargantext-client/Tracking.hs

+{-# LANGUAGE TupleSections #-}
+module Tracking
+  ( tracking
+  , ppTracked
+  , EkgMetric
+  , Step
+  ) where
+
+import Core
+import Options
+
+import Control.Monad.IO.Class
+import Data.List (intersperse)
+import Data.Text (Text)
+import Servant.Client
+import System.Metrics.Json (Value)
+
+import Gargantext.API.Client
+
+import qualified Data.Text as T
+
+-- | e.g @["rts", "gc", "bytes_allocated"]@
+type EkgMetric = [Text]
+-- | Any textual description of a step
+type Step      = Text
+
+-- | Track EKG metrics before/after running a bunch of computations
+--   that can talk to the backend.
+tracking
+  :: ClientOpts
+  -> [Text] -- ^ e.g @["rts.gc.bytes_allocated"]@
+  -> [(Step, ClientM a)]
+  -> ClientM [Either [(EkgMetric, Value)] (Step, a)]
+-- no steps, nothing to do
+tracking _    _   []    = return []
+-- no metrics to track, we just run the steps
+tracking _    []  steps = traverse runStep steps
+-- metrics to track: we intersperse metric fetching and steps,
+-- starting and ending with metric fetching
+tracking opts ms' steps = mix (Left <$> fetchMetrics) (map runStep steps)
+
+  where fetchMetrics :: ClientM [(EkgMetric, Value)]
+        fetchMetrics = flip traverse ms $ \metric -> do
+          whenVerbose opts $
+            liftIO . putStrLn $ "[Debug] metric to track: " ++ T.unpack (T.intercalate "." metric)
+          dat <- (metric,) <$> getMetricSample metric
+          whenVerbose opts $
+            liftIO . putStrLn $ "[Debug] metric pulled: " ++ show dat
+          return dat
+        mix :: ClientM a -> [ClientM a] -> ClientM [a]
+        mix x xs = sequence $ [x] ++ intersperse x xs ++ [x]
+        ms = map (T.splitOn ".") ms'
+
+-- ^ A trivial function to print results of steps and sampled metrics
+ppTracked :: Show a => [Either [(EkgMetric, Value)] (Step, a)] -> ClientM ()
+ppTracked [] = return ()
+ppTracked (Right (step, a) : rest) = do
+  liftIO . putStrLn $ "[step: " ++ T.unpack step ++ "] returned: " ++ show a
+  ppTracked rest
+ppTracked (Left ms : rest) = do
+  liftIO . putStrLn $ unlines
+    [ T.unpack (T.intercalate "." metric) ++ " = " ++ show val
+    | (metric, val) <- ms
+    ]
+  ppTracked rest
+
+runStep :: (Step, ClientM a) -> ClientM (Either e (Step, a))
+runStep (step, act) = Right . (step,) <$> act

cabal.project

 packages: .
-          -- ../servant-job
-          -- ../ekg-json
-          -- ../../../code/servant/servant
-          -- ../../../code/servant/servant-server
-          -- ../../../code/servant/servant-client-core
-          -- ../../../code/servant/servant-client
-          -- ../../../code/servant/servant-auth/servant-auth
-          -- ../../../code/servant/servant-auth/servant-auth-client
-          -- ../../../code/servant/servant-auth/servant-auth-server
-
-allow-newer: base, accelerate, servant, time
+
+allow-newer: base, accelerate, servant, time, classy-prelude
 
 -- Patches
 source-repository-package
@@ -20,7 +11,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/alpmestan/ekg-json.git
-  tag: c7bde4851a7cd41b3f3debf0c57f11bbcb11d698
+  tag: fd7e5d7325939103cd87d0dc592faf644160341c
 
 source-repository-package
   type: git
@@ -53,7 +44,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://gitlab.iscpif.fr/gargantext/crawlers/pubmed.git
-  tag: a9d8e08a7ef82f90e29dfaced4071704a3163394
+  tag: 9cdba6423decad5acfacb0f274212fd8723ce734
 
 source-repository-package
   type: git
@@ -112,7 +103,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/delanoe/haskell-opaleye.git
-  tag: d3ab7acd5ede737478763630035aa880f7e34444
+  tag: 756cb90f4ce725463d957bc899d764e0ed73738c
 
 source-repository-package
   type: git
@@ -146,4 +137,5 @@ source-repository-package
 
 constraints: unordered-containers==0.2.14.*,
              servant-ekg==0.3.1,
-             time==1.9.3
+             time==1.9.3,
+             stm==2.5.0.1

src/Gargantext/API/Client.hs

 {-# OPTIONS_GHC -freduction-depth=0 #-}
-{-# OPTIONS_GHC -O0                 #-} 
+{-# OPTIONS_GHC -O0                 #-}
 
 module Gargantext.API.Client where
 
@@ -55,17 +55,18 @@ import Servant.Job.Core
 import Servant.Job.Types
 import System.Metrics.Json (Sample, Value)
 
--- * actual client functions for individual endpoints
-
+-- * version API
 getBackendVersion :: ClientM Text
+
+-- * auth API
 postAuth :: AuthRequest -> ClientM AuthResponse
 
+-- * admin api
 getRoots :: Token -> ClientM [Node HyperdataUser]
 putRoots :: Token -> ClientM Int -- not actually implemented in the backend
 deleteNodes :: Token -> [NodeId] -> ClientM Int
 
-
+-- * node api
 getNode    :: Token -> NodeId -> ClientM (Node HyperdataAny)
 getContext :: Token -> ContextId -> ClientM (Node HyperdataAny)
 renameNode :: Token -> NodeId -> RenameNode -> ClientM [Int]
@@ -155,7 +156,7 @@ killNodeDocumentUploadAsyncJob :: Token -> NodeId -> JobID 'Unsafe -> Maybe Limi
 pollNodeDocumentUploadAsyncJob :: Token -> NodeId -> JobID 'Unsafe -> Maybe Limit -> Maybe Offset -> ClientM (JobStatus 'Safe JobLog)
 waitNodeDocumentUploadAsyncJob :: Token -> NodeId -> JobID 'Unsafe -> ClientM (JobOutput JobLog)
 
--- corpus api
+-- * corpus api
 getCorpus :: Token -> CorpusId -> ClientM (Node HyperdataCorpus)
 renameCorpus :: Token -> CorpusId -> RenameNode -> ClientM [Int]
 postCorpus :: Token -> CorpusId -> PostNode -> ClientM [CorpusId]
@@ -244,13 +245,13 @@ killCorpusDocumentUploadAsyncJob :: Token -> CorpusId -> JobID 'Unsafe -> Maybe
 pollCorpusDocumentUploadAsyncJob :: Token -> CorpusId -> JobID 'Unsafe -> Maybe Limit -> Maybe Offset -> ClientM (JobStatus 'Safe JobLog)
 waitCorpusDocumentUploadAsyncJob :: Token -> CorpusId -> JobID 'Unsafe -> ClientM (JobOutput JobLog)
 
--- corpus node/node API
+-- * corpus node/node API
 getCorpusNodeNode :: Token -> NodeId -> NodeId -> ClientM (Node HyperdataAny)
 
--- corpus export API
+-- * corpus export API
 getCorpusExport :: Token -> CorpusId -> Maybe ListId -> Maybe NgramsType -> ClientM Corpus
 
+-- * annuaire api
 getAnnuaire :: Token -> AnnuaireId -> ClientM (Node HyperdataAnnuaire)
 renameAnnuaire :: Token -> AnnuaireId -> RenameNode -> ClientM [Int]
 postAnnuaire :: Token -> AnnuaireId -> PostNode -> ClientM [AnnuaireId]
@@ -338,17 +339,17 @@ killAnnuaireDocumentUploadAsyncJob :: Token -> AnnuaireId -> JobID 'Unsafe -> Ma
 pollAnnuaireDocumentUploadAsyncJob :: Token -> AnnuaireId -> JobID 'Unsafe -> Maybe Limit -> Maybe Offset -> ClientM (JobStatus 'Safe JobLog)
 waitAnnuaireDocumentUploadAsyncJob :: Token -> AnnuaireId -> JobID 'Unsafe -> ClientM (JobOutput JobLog)
 
--- contact api
+-- * contact api
 postAnnuaireContactAsync :: Token -> AnnuaireId -> ClientM (JobStatus 'Safe JobLog)
 postAnnuaireContactAsyncJob :: Token -> AnnuaireId -> JobInput Maybe AddContactParams -> ClientM (JobStatus 'Safe JobLog)
 killAnnuaireContactAsyncJob :: Token -> AnnuaireId -> JobID 'Unsafe -> Maybe Limit -> Maybe Offset -> ClientM (JobStatus 'Safe JobLog)
 pollAnnuaireContactAsyncJob :: Token -> AnnuaireId -> JobID 'Unsafe -> Maybe Limit -> Maybe Offset -> ClientM (JobStatus 'Safe JobLog)
 waitAnnuaireContactAsyncJob :: Token -> AnnuaireId -> JobID 'Unsafe -> ClientM (JobOutput JobLog)
 
--- contact node/node API
+-- * contact node/node API
 getAnnuaireContactNodeNode :: Token -> NodeId -> NodeId -> ClientM (Node HyperdataContact)
 
--- document ngrams api
+-- * document ngrams api
 getDocumentNgramsTable :: Token -> DocId -> TabType -> ListId -> Int -> Maybe Int -> Maybe ListType -> Maybe MinSize -> Maybe MaxSize -> Maybe Ngrams.OrderBy -> Maybe Text -> ClientM (VersionedWithCount NgramsTable)
 putDocumentNgramsTable :: Token -> DocId -> TabType -> ListId -> Versioned NgramsTablePatch -> ClientM (Versioned NgramsTablePatch)
 postRecomputeDocumentNgramsTableScore :: Token -> DocId -> TabType -> ListId -> ClientM Int
@@ -359,15 +360,14 @@ killDocumentNgramsTableAsyncJob :: Token -> DocId -> JobID 'Unsafe -> Maybe Limi
 pollDocumentNgramsTableAsyncJob :: Token -> DocId -> JobID 'Unsafe -> Maybe Limit -> Maybe Offset -> ClientM (JobStatus 'Safe JobLog)
 waitDocumentNgramsTableAsyncJob :: Token -> DocId -> JobID 'Unsafe -> ClientM (JobOutput JobLog)
 
--- document export API
+-- * document export API
 getDocumentExportJSON :: Token -> DocId -> ClientM DocumentExport.DocumentExport
 getDocumentExportCSV :: Token -> DocId -> ClientM Text
---getDocumentExportCSV :: Token -> DocId -> ClientM [DocumentExport.Document]
 
--- count api
+-- * count api
 postCountQuery :: Token -> Query -> ClientM Counts
 
--- graph api
+-- * graph api
 getGraphHyperdata :: Token -> NodeId -> ClientM HyperdataGraphAPI
 postGraphAsync :: Token -> NodeId -> ClientM (JobStatus 'Safe JobLog)
 postGraphAsyncJob :: Token -> NodeId -> JobInput Maybe () -> ClientM (JobStatus 'Safe JobLog)
@@ -382,6 +382,7 @@ postGraphRecomputeVersion :: Token -> NodeId -> ClientM Graph
 getTree :: Token -> NodeId -> [NodeType] -> ClientM (Tree NodeTree)
 getTreeFirstLevel :: Token -> NodeId -> [NodeType] -> ClientM (Tree NodeTree)
 
+-- * new corpus API
 postNewCorpusWithFormAsync :: Token -> NodeId -> ClientM (JobStatus 'Safe JobLog)
 postNewCorpusWithFormAsyncJob :: Token -> NodeId -> JobInput Maybe NewWithForm -> ClientM (JobStatus 'Safe JobLog)
 killNewCorpusWithFormAsyncJob :: Token -> NodeId -> JobID 'Unsafe -> Maybe Limit -> Maybe Offset -> ClientM (JobStatus 'Safe JobLog)
@@ -394,6 +395,7 @@ killNewCorpusWithQueryAsyncJob :: Token -> NodeId -> JobID 'Unsafe -> Maybe Limi
 pollNewCorpusWithQueryAsyncJob :: Token -> NodeId -> JobID 'Unsafe -> Maybe Limit -> Maybe Offset -> ClientM (JobStatus 'Safe JobLog)
 waitNewCorpusWithQueryAsyncJob :: Token -> NodeId -> JobID 'Unsafe -> ClientM (JobOutput JobLog)
 
+-- * list API
 getList :: Token -> NodeId -> ClientM (Headers '[Header "Content-Disposition" Text] (Map NgramsType (Versioned NgramsTableMap)))
 postListJsonUpdateAsync :: Token -> NodeId -> ClientM (JobStatus 'Safe JobLog)
 postListJsonUpdateAsyncJob :: Token -> NodeId -> JobInput Maybe WithFile -> ClientM (JobStatus 'Safe JobLog)
@@ -407,11 +409,14 @@ killListCsvUpdateAsyncJob :: Token -> NodeId -> JobID 'Unsafe -> Maybe Limit  ->
 pollListCsvUpdateAsyncJob :: Token -> NodeId -> JobID 'Unsafe -> Maybe Limit  -> Maybe Offset -> ClientM (JobStatus 'Safe JobLog)
 waitListCsvUpdateAsyncJob :: Token -> NodeId -> JobID 'Unsafe -> ClientM (JobOutput JobLog)
 
+-- * public API
 getPublicData :: ClientM [PublicData]
 getPublicNodeFile :: NodeId -> ClientM (Headers '[Header "Content-Type" Text] BSResponse)
 
--- ekg api
+-- * ekg api
+-- | get a sample of all metrics
 getMetricsSample :: ClientM Sample
+-- | open @<backend:port\/ekg\/index.html@ to see a list of metrics
 getMetricSample :: [Text] -> ClientM Value
 
 -- * unpacking of client functions to derive all the individual clients

stack.yaml

@@ -57,7 +57,7 @@ extra-deps:
 - git: https://github.com/delanoe/servant-static-th.git
   commit: 8cb8aaf2962ad44d319fcea48442e4397b3c49e8
 - git: https://github.com/alpmestan/ekg-json.git
-  commit: c7bde4851a7cd41b3f3debf0c57f11bbcb11d698
+  commit: fd7e5d7325939103cd87d0dc592faf644160341c
 
   # Databases libs
 - git: https://github.com/delanoe/haskell-opaleye.git