Experiment with reverse proxy same domain

cabal.project

@@ -7,6 +7,7 @@ optimization: 2
 
 packages:
     ./
+    ../../../../../programming/haskell/http-reverse-proxy
 
 source-repository-package
     type: git

gargantext.cabal

@@ -561,6 +561,7 @@ library
     , http-conduit ^>= 2.3.8
     , http-media ^>= 0.8.0.0
     , http-types ^>= 0.12.3
+    , http-reverse-proxy
     , hxt ^>= 9.3.1.22
     , ihaskell >= 0.11.0.0
     -- necessary for ihaskell to build
@@ -614,6 +615,7 @@ library
     , rake ^>= 0.0.1
     , random ^>= 1.2.1
     , rdf4h ^>= 3.1.1
+    , recover-rtti >= 0.4 && < 0.5
     , regex-compat ^>= 0.95.2.1
     , regex-tdfa ^>= 1.3.1.2
     , replace-attoparsec ^>= 1.4.5.0

src/Gargantext/API/Routes/Named/Private.hs

@@ -13,11 +13,15 @@ module Gargantext.API.Routes.Named.Private (
   , NodeAPIEndpoint(..)
   , MembersAPI(..)
   , IsGenericNodeRoute(..)
+  , NotesProxy(..)
   ) where
 
 
+import Data.Kind
 import Data.Text (Text)
+import Data.Text qualified as T
 import GHC.Generics
+import GHC.TypeLits
 import Gargantext.API.Admin.Auth.Types
 import Gargantext.API.Auth.PolicyCheck
 import Gargantext.API.Routes.Named.Contact
@@ -25,19 +29,17 @@ import Gargantext.API.Routes.Named.Context
 import Gargantext.API.Routes.Named.Corpus
 import Gargantext.API.Routes.Named.Count
 import Gargantext.API.Routes.Named.Document
-import Gargantext.API.Routes.Named.Node
 import Gargantext.API.Routes.Named.List qualified as List
+import Gargantext.API.Routes.Named.Node
 import Gargantext.API.Routes.Named.Share
-import Gargantext.API.Routes.Named.Tree
 import Gargantext.API.Routes.Named.Table
+import Gargantext.API.Routes.Named.Tree
 import Gargantext.API.Routes.Named.Viz
 import Gargantext.Database.Admin.Types.Hyperdata.Any
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus
 import Gargantext.Database.Admin.Types.Node
 import Servant.API
 import Servant.Auth qualified as SA
-import Data.Kind
-import GHC.TypeLits
 
 
 type MkProtectedAPI private = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser :> private
@@ -93,6 +95,15 @@ data GargPrivateAPI' mode = GargPrivateAPI'
   , listJsonAPI    :: mode :- NamedRoutes List.JSONAPI
   , listTsvAPI     :: mode :- NamedRoutes List.TSVAPI
   , shareUrlEp     :: mode :- "shareurl" :> NamedRoutes ShareURL
+
+  -- Proxies for microservices
+  , notesProxy     :: mode :- "notes-proxy" :> NamedRoutes NotesProxy
+  } deriving Generic
+
+
+data NotesProxy mode = NotesProxy
+  { noteProxyEp :: mode :- Capture "frameId" T.Text
+                        :> Raw
   } deriving Generic
 
 

src/Gargantext/API/Server/Named.hs

@@ -31,15 +31,15 @@ import Servant
 import Servant.Server.Generic
 import Servant.Swagger.UI (swaggerSchemaUIServer)
 
-serverGargAPI :: Text -> BackEndAPI (AsServerT (GargM Env BackendInternalError))
-serverGargAPI baseUrl
+serverGargAPI :: Env -> BackEndAPI (AsServerT (GargM Env BackendInternalError))
+serverGargAPI env
        =  BackEndAPI $ MkBackEndAPI $ GargAPIVersion $ GargAPI'
             { gargAuthAPI                = AuthAPI auth
             , gargForgotPasswordAPI      = forgotPassword
             , gargForgotPasswordAsyncAPI = forgotPasswordAsync
             , gargVersionAPI             = gargVersion
-            , gargPrivateAPI             = serverPrivateGargAPI
-            , gargPublicAPI              = serverPublicGargAPI baseUrl
+            , gargPrivateAPI             = serverPrivateGargAPI env
+            , gargPublicAPI              = serverPublicGargAPI (env ^. hasConfig . gc_url_backend_api)
             }
   where
     gargVersion :: GargVersion (AsServerT (GargM Env BackendInternalError))
@@ -54,7 +54,7 @@ server env =
                       (Proxy :: Proxy (NamedRoutes BackEndAPI))
                       (Proxy :: Proxy AuthContext)
                       (transformJSON errScheme)
-                      (serverGargAPI (env ^. hasConfig . gc_url_backend_api))
+                      (serverGargAPI env)
      , graphqlAPI = hoistServerWithContext
                       (Proxy :: Proxy (NamedRoutes GraphQLAPI))
                       (Proxy :: Proxy AuthContext)

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

-
+{-# OPTIONS_GHC -Wno-deprecations #-}
 module Gargantext.API.Server.Named.Private where
 
+import Conduit
+import Data.ByteString qualified as B
+import Data.ByteString.Builder
+import Data.ByteString.Char8 qualified as C8
+import Data.Conduit.List qualified as CC
+import Data.String
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as TE
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(..))
-import Gargantext.API.Admin.EnvTypes (Env)
+import Gargantext.API.Admin.EnvTypes (Env, env_manager)
 import Gargantext.API.Context
 import Gargantext.API.Count qualified as Count
 import Gargantext.API.Errors.Types
@@ -22,11 +30,18 @@ import Gargantext.API.Server.Named.Ngrams
 import Gargantext.API.Server.Named.Viz qualified as Viz
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Admin.Types.Hyperdata
+import Gargantext.Database.Prelude (hasConfig)
 import Gargantext.Prelude
+import Gargantext.Prelude.Config (gc_frame_write_url)
+import Network.HTTP.ReverseProxy
+import Network.HTTP.Types (hCacheControl, RequestHeaders, Header, HeaderName)
+import Network.HTTP.Types.Header (hHost)
+import Network.URI as URI
+import Network.Wai (Request, rawPathInfo, requestHeaders)
+import Servant hiding (Header)
 import Servant.Auth.Swagger ()
 import Servant.Server.Generic (AsServerT)
 
-
 ---------------------------------------------------------------------
 -- | Server declarations
 
@@ -40,8 +55,8 @@ serverGargAdminAPI = Named.GargAdminAPI
 
 
 serverPrivateGargAPI'
-  :: AuthenticatedUser -> Named.GargPrivateAPI' (AsServerT (GargM Env BackendInternalError))
-serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
+  :: Env -> AuthenticatedUser -> Named.GargPrivateAPI' (AsServerT (GargM Env BackendInternalError))
+serverPrivateGargAPI' env authenticatedUser@(AuthenticatedUser userNodeId userId)
        =  Named.GargPrivateAPI'
        { gargAdminAPI      = serverGargAdminAPI
        , nodeEp            = nodeAPI authenticatedUser
@@ -65,4 +80,78 @@ serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
        , listJsonAPI       = List.jsonAPI
        , listTsvAPI        = List.tsvAPI
        , shareUrlEp        = shareURL
+       , notesProxy        = notesProxyImplementation env
+       }
+
+notesProxyImplementation :: Env -> Named.NotesProxy (AsServerT (GargM Env BackendInternalError))
+notesProxyImplementation env = Named.NotesProxy $ \_frameId -> forwardServer env
+
+forwardServer :: Env -> ServerT Raw m
+forwardServer env =
+  Tagged $ waiProxyToSettings forwardRequest proxySettings (env ^. env_manager)
+  where
+    writeFrameURL :: T.Text
+    writeFrameURL = env ^. hasConfig . gc_frame_write_url
+
+    assetPath :: T.Text
+    assetPath
+      | snd forwardedHost /= 80
+      = writeFrameURL <> ":" <> T.pack (show $ snd forwardedHost)
+      | otherwise
+      = writeFrameURL
+
+    removeProxyPath :: ByteString -> ByteString
+    removeProxyPath = TE.encodeUtf8
+                    . T.replace "/api/v1.0/notes-proxy" ""
+                    . TE.decodeUtf8
+
+    proxySettings :: WaiProxySettings
+    proxySettings = defaultWaiProxySettings { wpsLogRequest = \req -> traceShow req $ pure ()
+                                            , wpsProcessBody =
+                                                \_req _res -> Just replaceRelativeLinks
+                                            }
+
+    replaceRelativeLinks :: ConduitT B.ByteString (Flush Builder) IO ()
+    replaceRelativeLinks = CC.map flushReplace
+      where
+        -- FIXME(adn) performance.
+        flushReplace :: B.ByteString -> Flush Builder
+        flushReplace bs = Chunk $ byteString $ traceShowId $ TE.encodeUtf8 . replaceIt . TE.decodeUtf8 $ bs
+
+        replaceIt :: T.Text -> T.Text
+        replaceIt t = t & T.replace "src=\"/build/" ("src=\"" <> assetPath <> "/build/")
+                        & T.replace "href=\"/build/" ("href=\"" <> assetPath <> "/build/")
+                        & T.replace "src=\"/config" ("src=\"" <> assetPath <> "/config")
+                        & T.replace "src=\"/js" ("src=\"" <> assetPath <> "/js")
+
+    noCache :: RequestHeaders -> RequestHeaders
+    noCache hdrs = (hCacheControl, fromString "no-cache") :
+      filter ((/=) hCacheControl . fst) hdrs
+
+    newHost :: RequestHeaders -> RequestHeaders
+    newHost hdrs =
+      (hHost, fromString $ fst forwardedHost <> ":" <> show (snd forwardedHost)) :
+      filter ((/=) hHost . fst) hdrs
+
+    forwardedHost :: (String, Int)
+    forwardedHost = fromMaybe (panicTrace "Invalid URI found in the proxied Request.") $ do
+      URI{..} <- URI.parseURI (T.unpack writeFrameURL)
+      uriAut  <- uriAuthority
+      port    <- case uriPort uriAut of
+        "" -> pure 80
+        xs -> readMaybe (dropWhile (==':') xs)
+      pure $ (uriRegName uriAut, port)
+
+    mkProxyDest :: ProxyDest
+    mkProxyDest =
+      let (hst, prt) = forwardedHost
+      in ProxyDest (C8.pack hst) prt
+
+    -- | Forwards the request by substituting back the proxied address into the actual one.
+    forwardRequest :: Request -> IO WaiProxyResponse
+    forwardRequest originalRequest = do
+      let proxiedReq = originalRequest {
+                           rawPathInfo = removeProxyPath (rawPathInfo originalRequest)
+                         , requestHeaders = (newHost $ noCache $ (requestHeaders originalRequest))
                          }
+      pure $ WPRModifiedRequest (traceShowId proxiedReq) $ traceShowId $ mkProxyDest

src/Gargantext/API/ThrowAll.hs

@@ -49,11 +49,11 @@ throwAll' errCode server =
     f :: forall a. m a -> m a
     f = const (throwError errCode)
 
-serverPrivateGargAPI :: Named.GargPrivateAPI (AsServerT (GargM Env BackendInternalError))
-serverPrivateGargAPI = Named.GargPrivateAPI $ \case
-  (Authenticated auser) -> Named.serverPrivateGargAPI' auser
+serverPrivateGargAPI :: Env -> Named.GargPrivateAPI (AsServerT (GargM Env BackendInternalError))
+serverPrivateGargAPI env = Named.GargPrivateAPI $ \case
+  (Authenticated auser) -> Named.serverPrivateGargAPI' env auser
   -- In the code below we just needed a mock 'AuthenticatedUser' to make the type check, but
   -- they will never be evaluated.
   _                     -> throwAll' (_ServerError # err401)
-                             $ Named.serverPrivateGargAPI' (AuthenticatedUser 0 (UnsafeMkUserId 0))
+                             $ Named.serverPrivateGargAPI' env (AuthenticatedUser 0 (UnsafeMkUserId 0))
 -- Here throwAll' requires a concrete type for the monad.

src/Gargantext/Database/Action/Node.hs

@@ -21,6 +21,7 @@ module Gargantext.Database.Action.Node
   where
 
 import Control.Lens (view)
+import Data.Text qualified as T
 import Gargantext.Core
 import Gargantext.Core.Types (Name)
 import Gargantext.Database.Admin.Types.Hyperdata
@@ -92,6 +93,8 @@ mkNodeWithParent_ConfigureHyperdata NodeFrameNotebook (Just i) uId name = (:[])
 
 mkNodeWithParent_ConfigureHyperdata    _ _ _ _ = nodeError NotImplYet
 
+internalNotesProxy :: GargConfig -> T.Text
+internalNotesProxy cfg = _gc_url_backend_api cfg <> "/notes-proxy"
 
 -- | Function not exposed
 mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType)
@@ -109,7 +112,7 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
 
   cfg <- view hasConfig
   u <- case nt of
-        Notes -> pure $ _gc_frame_write_url cfg
+        Notes -> pure $ internalNotesProxy cfg
         Calc  -> pure $ _gc_frame_calc_url  cfg
         NodeFrameVisio -> pure $ _gc_frame_visio_url  cfg
         _              -> nodeError NeedsConfiguration