Integrate servant-routes

bin/gargantext-routes/Main.hs

+{-# LANGUAGE LambdaCase      #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Main where
+
+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
+
+data CLIRoutes
+  = CLIR_list
+  | CLIR_export FilePath
+  deriving (Show, Eq)
+
+data CLI =
+  CLIRoutesSub CLIRoutes
+
+cli :: Parser CLI
+cli = CLIRoutesSub <$> (
+  (flag' CLIR_list
+          ( long "list"
+         <> help "List all the available routes" ))
+      <|> (CLIR_export <$> strOption
+          ( long "export"
+         <> metavar "output.json"
+         <> help "Export the routes to a file." ))
+  )
+
+main :: IO ()
+main = runCLI =<< execParser opts
+  where
+    opts = info (cli <**> helper)
+      ( fullDesc
+     <> progDesc "Print and exports routes for gargantext"
+     <> header "garg-routes helper" )
+
+instance HasRoutes api => HasRoutes (Servant.Auth xs a :> api) where
+  getRoutes = getRoutes @api
+
+instance HasRoutes Raw where
+  getRoutes = []
+
+runCLI :: CLI -> IO ()
+runCLI = \case
+  CLIRoutesSub CLIR_list
+    -> printRoutes @(NamedRoutes API)
+  CLIRoutesSub (CLIR_export filePath)
+    -> B.writeFile filePath . BL.toStrict $ encodePretty (getRoutes @(NamedRoutes API))

cabal.project

@@ -165,7 +165,12 @@ source-repository-package
     type: git
     location: https://github.com/robstewart57/rdf4h.git
     tag: 4fd2edf30c141600ffad6d730cc4c1c08a6dbce4
-    
+
+source-repository-package
+    type: git
+    location: https://github.com/fpringle/servant-routes.git
+    tag: 7694f62af6bc1596d754b42af16da131ac403b3a
+
 allow-older: *
 allow-newer: *
 

gargantext.cabal

@@ -640,6 +640,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
@@ -1144,3 +1145,21 @@ executable garg-golden-file-diff
     , text
     , tree-diff
   default-language: Haskell2010
+
+executable garg-routes
+  import:
+      defaults
+    , optimized
+  main-is: Main.hs
+  hs-source-dirs:
+      bin/gargantext-routes
+  build-depends:
+      base
+    , gargantext
+    , optparse-applicative
+    , servant-routes
+    , servant
+    , servant-auth
+    , aeson-pretty
+    , bytestring
+  default-language: GHC2021

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.Prelude.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