Add routes subcommand to CLI

It integrates servant-routes which allows to list and export the
server backend routes.

bin/gargantext-cli/CLI/Server/Routes.hs

+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wno-orphans     #-}
+
+module CLI.Server.Routes (
+    routesCLI
+  , routesCmd
+  ) where
+
+import CLI.Types
+import Data.Aeson.Encode.Pretty
+import Data.ByteString qualified as B
+import Data.ByteString.Lazy qualified as BL
+import Gargantext.API.Routes.Named
+import Options.Applicative
+import Prelude
+import Servant.API
+import Servant.API.Routes
+import Servant.Auth qualified as Servant
+
+routesCmd :: Mod CommandFields CLI
+routesCmd = command "routes" (info (helper <*> (fmap CLISub $ fmap CCMD_routes routesParser))
+                                   (progDesc "Server routes related commands."))
+
+routesParser :: Parser CLIRoutes
+routesParser = hsubparser (
+  (command "list" (info (helper <*> list_p)
+                                   (progDesc "List all the available routes, computed by the Routes types."))) <>
+  (command "export" (info (helper <*> export_p)
+                                   (progDesc "Exports all the routes into a file, for golden-diff testing.")))
+  )
+
+list_p :: Parser CLIRoutes
+list_p = pure CLIR_list
+
+export_p :: Parser CLIRoutes
+export_p = CLIR_export <$>
+  strOption ( long "file" <> metavar "output.json" <> help "Export the routes to a file." )
+
+instance HasRoutes api => HasRoutes (Servant.Auth xs a :> api) where
+  getRoutes = getRoutes @api
+
+instance HasRoutes Raw where
+  getRoutes = []
+
+routesCLI :: CLIRoutes -> IO ()
+routesCLI = \case
+  CLIR_list
+    -> printRoutes @(NamedRoutes API)
+  (CLIR_export filePath)
+    -> B.writeFile filePath . BL.toStrict $ encodePretty (getRoutes @(NamedRoutes API))

bin/gargantext-cli/CLI/Types.hs

@@ -68,6 +68,11 @@ data GoldenFileDiffArgs = GoldenFileDiffArgs
   , gdf_actual   :: !FilePath
   } deriving (Show, Eq)
 
+data CLIRoutes
+  = CLIR_list
+  | CLIR_export FilePath
+  deriving (Show, Eq)
+
 data CLICmd
   = CCMD_clean_csv_corpus
   | CCMD_filter_terms_and_cooc !CorpusFile !TermListFile !OutputFile
@@ -80,6 +85,7 @@ data CLICmd
   | CCMD_phylo_profile
   | CCMD_upgrade !UpgradeArgs
   | CCMD_golden_file_diff !GoldenFileDiffArgs
+  | CCMD_routes !CLIRoutes
   deriving (Show, Eq)
 
 data CLI =

bin/gargantext-cli/Main.hs

@@ -24,13 +24,14 @@ import CLI.ObfuscateDB (obfuscateDB, obfuscateDBCmd)
 import CLI.Types
 import Options.Applicative
 import CLI.Admin (adminCLI, adminCmd)
+import CLI.FileDiff (fileDiffCLI, fileDiffCmd)
 import CLI.Import (importCLI, importCmd)
 import CLI.Init (initCLI, initCmd)
 import CLI.Invitations (invitationsCLI, invitationsCmd)
 import CLI.Phylo (phyloCLI, phyloCmd)
 import CLI.Phylo.Profile (phyloProfileCLI, phyloProfileCmd)
+import CLI.Server.Routes (routesCLI, routesCmd)
 import CLI.Upgrade (upgradeCLI, upgradeCmd)
-import CLI.FileDiff (fileDiffCLI, fileDiffCmd)
 
 runCLI :: CLI -> IO ()
 runCLI = \case
@@ -56,6 +57,9 @@ runCLI = \case
     -> upgradeCLI args
   CLISub (CCMD_golden_file_diff args)
     -> fileDiffCLI args
+  CLISub (CCMD_routes args)
+    -> routesCLI args
+
 
 main :: IO ()
 main = runCLI =<< execParser opts
@@ -76,5 +80,6 @@ allOptions = subparser (
                  phyloCmd <>
                  phyloProfileCmd <>
                  upgradeCmd <>
-                 fileDiffCmd
+                 fileDiffCmd <>
+                 routesCmd
                  )

bin/update-project-dependencies

@@ -18,8 +18,8 @@ fi
 # with the `sha256sum` result calculated on the `cabal.project` and
 # `cabal.project.freeze`. This ensures the files stay deterministic so that CI
 # cache can kick in.
-expected_cabal_project_hash="9e32b45568d34952aaa77884dcc5e9bb7317fe8c5bc2c45267ea7178332852e8"
-expected_cabal_project_freeze_hash="7bb3ba71d0a1881a5c4fd420b9988155586e0cf51e9b6d55867bce3d311d59a5"
+expected_cabal_project_hash="653b7bf4f98be8f7eb85ba082399986afb94a6d16a625207e8c78246ede565b2"
+expected_cabal_project_freeze_hash="ca1592c985ffead024c6635eb39b293e2525a547fe93293fdee9ce1148083f22"
 
 cabal --store-dir=$STORE_DIR v2-build --dry-run
 cabal2stack --system-ghc --allow-newer --resolver lts-21.17 --resolver-file devops/stack/lts-21.17.yaml -o stack.yaml

cabal.project

@@ -170,6 +170,11 @@ source-repository-package
     location: https://github.com/adinapoli/http-reverse-proxy.git
     tag: c90b7bc55b0e628d0b71ccee4e222833a19792f8
 
+source-repository-package
+    type: git
+    location: https://github.com/fpringle/servant-routes.git
+    tag: 7694f62af6bc1596d754b42af16da131ac403b3a
+
 allow-older: *
 allow-newer: *
 

cabal.project.freeze

@@ -347,6 +347,7 @@ constraints: any.Cabal ==3.8.1.0,
              any.memory ==0.18.0,
              memory +support_bytestring +support_deepseq,
              any.microlens ==0.4.13.1,
+             any.microlens-th ==0.4.3.14,
              any.microstache ==1.0.2.3,
              any.mime-mail ==0.5.1,
              any.mime-types ==0.1.2.0,
@@ -501,6 +502,7 @@ constraints: any.Cabal ==3.8.1.0,
              any.servant-job ==0.2.0.0,
              any.servant-multipart ==0.12.1,
              any.servant-multipart-api ==0.12.1,
+             any.servant-routes ==0.1.0.0,
              any.servant-server ==0.20,
              any.servant-swagger ==1.2,
              any.servant-swagger-ui ==0.3.5.5.0.0,

gargantext.cabal

@@ -648,6 +648,7 @@ library
     , servant-flatten ^>= 0.2
     , servant-job >= 0.2.0.0
     , servant-multipart ^>= 0.12.1
+    , servant-routes < 0.2
     , servant-server >= 0.18.3 && < 0.20
     , servant-swagger >= 1.2
     , servant-swagger-ui ^>= 0.3.5.3.5.0
@@ -715,6 +716,7 @@ executable gargantext-cli
       CLI.Phylo
       CLI.Phylo.Common
       CLI.Phylo.Profile
+      CLI.Server.Routes
       CLI.Types
       CLI.Upgrade
       CLI.Utils
@@ -723,6 +725,7 @@ executable gargantext-cli
       bin/gargantext-cli
   build-depends:
       aeson ^>= 1.5.6.0
+    , aeson-pretty
     , async ^>= 2.2.4
     , bytestring ^>= 0.10.12.0
     , cassava ^>= 0.5.2.0
@@ -739,6 +742,9 @@ executable gargantext-cli
     , parallel ^>= 3.2.2.0
     , postgresql-simple ^>= 0.6.4
     , protolude ^>= 0.3.3
+    , servant
+    , servant-auth
+    , servant-routes < 0.2
     , shelly
     , split ^>= 0.2.3.4
     , text ^>= 1.2.4.1

src/Gargantext/API/Auth/PolicyCheck.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE TypeApplications    #-}
 
 module Gargantext.API.Auth.PolicyCheck (
     AccessCheck(..)
@@ -34,12 +35,13 @@ import Gargantext.Database.Query.Tree.Root
 import Gargantext.Core.Config (GargConfig(..))
 import Prelude
 import Servant
+import Servant.API.Routes
 import Servant.Auth.Server.Internal.AddSetCookie
+import Servant.Client.Core
 import Servant.Ekg
 import Servant.Server.Internal.Delayed
 import Servant.Server.Internal.DelayedIO
-import qualified Servant.Swagger as Swagger
-import Servant.Client.Core
+import Servant.Swagger qualified as Swagger
 
 -------------------------------------------------------------------------------
 -- Types
@@ -203,6 +205,11 @@ instance HasClient m sub => HasClient m (PolicyChecked sub) where
 
   hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt . cl
 
+instance (HasRoutes subApi) => HasRoutes (PolicyChecked subApi) where
+  getRoutes =
+    let apiRoutes = getRoutes @subApi
+    in  apiRoutes
+
 -------------------------------------------------------------------------------
 -- Utility functions
 -------------------------------------------------------------------------------

src/Gargantext/API/Routes/Types.hs

 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeApplications     #-}
 module Gargantext.API.Routes.Types where
 
+import Control.Lens
+import Data.ByteString (ByteString)
 import Data.List qualified as L
 import Data.Proxy
+import Data.Set qualified as Set
 import Gargantext.API.Errors
-import Network.Wai
+import Network.Wai hiding (responseHeaders)
 import Prelude
-import Servant.Client
+import Servant.API.Routes
+import Servant.Client hiding (responseHeaders)
 import Servant.Ekg
 import Servant.Server
 import Servant.Server.Internal.Delayed
 import Servant.Server.Internal.DelayedIO
+import Servant.API.Routes.Route
+import Servant.API.Routes.Internal.Response (unResponses)
 
 data WithCustomErrorScheme a
 
@@ -37,3 +44,10 @@ instance HasClient m sub => HasClient m (WithCustomErrorScheme sub) where
   clientWithRoute m _ req _mgr = clientWithRoute m (Proxy :: Proxy sub) req
 
   hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy sub) nt . cl
+
+instance (HasRoutes subApi) => HasRoutes (WithCustomErrorScheme subApi) where
+  getRoutes =
+    let apiRoutes = getRoutes @subApi
+        errHeader = mkHeaderRep @"X-Garg-Error-Scheme" @ByteString
+        addHeader rt = rt & routeResponse . unResponses . traversed . responseHeaders %~ Set.insert errHeader
+    in  addHeader <$> apiRoutes

src/Gargantext/API/Server/Named/EKG.hs

@@ -9,15 +9,15 @@ import Data.HashMap.Strict as HM
 import Data.Text as T
 import Data.Text.IO as T
 import Data.Time.Clock.POSIX (getPOSIXTime)
+import Gargantext.API.Routes.Named.EKG
 import Network.Wai
 import Protolude
 import Servant
 import Servant.Auth
 import Servant.Ekg
-import System.Metrics
-import qualified System.Metrics.Json as J
-import Gargantext.API.Routes.Named.EKG
 import Servant.Server.Generic
+import System.Metrics
+import System.Metrics.Json qualified as J
 
 
 ekgServer :: FilePath -> Store -> EkgAPI AsServer

stack.yaml

@@ -106,6 +106,10 @@
   git: "https://github.com/delanoe/patches-map"
   subdirs:
   - .
+- commit: 7694f62af6bc1596d754b42af16da131ac403b3a
+  git: "https://github.com/fpringle/servant-routes.git"
+  subdirs:
+  - .
 - commit: 4fd2edf30c141600ffad6d730cc4c1c08a6dbce4
   git: "https://github.com/robstewart57/rdf4h.git"
   subdirs: