Slight refactoring of proxy code

src/Gargantext/MicroServices/ReverseProxy.hs

@@ -4,9 +4,6 @@
 
 module Gargantext.MicroServices.ReverseProxy (
   microServicesProxyApp
-
-  -- * Internals
-  , replaceIt
   ) where
 
 import Prelude
@@ -41,6 +38,21 @@ import Text.RE.Replace hiding (Capture)
 -- Types
 --
 
+data ProxyDestination =
+  ProxyDestination
+    { fwdProto :: C8.ByteString
+    , fwdHost  :: C8.ByteString
+    , fwdPort  :: PortNumber
+    }
+
+renderProxyDestination :: ProxyDestination -> C8.ByteString
+renderProxyDestination ProxyDestination{..}
+  = fwdProto <> "//" <> fwdHost <> ":" <> C8.pack (Prelude.show fwdPort)
+
+--
+-- The API
+--
+
 data ReverseProxyAPI mode = ReverseProxyAPI
   { notesProxy    :: mode :- "notes-proxy" :> NamedRoutes NotesProxy
   , notesSocketIo :: mode :- "socket.io"   :> NamedRoutes SocketIOProxy
@@ -48,8 +60,8 @@ data ReverseProxyAPI mode = ReverseProxyAPI
   } deriving Generic
 
 data NotesProxy mode = NotesProxy
-  { noteProxyEp :: mode :- Capture "frameId" T.Text
-                        :> Raw
+  { noteProxyEp :: mode :- Capture "frameId" T.Text :> Raw
+  , slideEp     :: mode :- Capture "frameId" T.Text :> "slide" :> Raw
   } deriving Generic
 
 data SocketIOProxy mode = SocketIOProxy
@@ -57,7 +69,7 @@ data SocketIOProxy mode = SocketIOProxy
   } deriving Generic
 
 --
--- Server
+-- The Server
 --
 
 microServicesProxyApp :: Env -> Application
@@ -67,91 +79,108 @@ server :: Env -> ReverseProxyAPI AsServer
 server env = ReverseProxyAPI {
     notesProxy    = notesProxyImplementation env
   , notesSocketIo = socketIOProxyImplementation env
-  , meEndpoint    = forwardServer env
+  , meEndpoint    = proxyPassServer env
   }
 
 notesProxyImplementation :: Env -> NotesProxy AsServer
 notesProxyImplementation env = NotesProxy {
-    noteProxyEp = \_frameId -> forwardServer env
+    noteProxyEp = \_frameId -> notesProxyServer env
+  , slideEp     = \frameId  -> slideProxyServer env frameId
   }
 
 socketIOProxyImplementation :: Env -> SocketIOProxy AsServer
 socketIOProxyImplementation env = SocketIOProxy {
-    socketIoEp = \_noteId -> forwardServer env
+    socketIoEp = \_noteId -> proxyPassServer env
   }
 
-forwardServer :: Env -> ServerT Raw m
-forwardServer env =
-  Tagged $ waiProxyToSettings forwardRequest proxySettings (env ^. env_manager)
+notesProxyServer :: Env -> ServerT Raw m
+notesProxyServer env = defaultForwardServer (removeProxyPath "/notes-proxy") env
+
+slideProxyServer :: Env -> T.Text -> ServerT Raw m
+slideProxyServer env frameId =
+  defaultForwardServer (\rq -> rq { rawPathInfo = changePath (rawPathInfo rq) }) env
   where
+    changePath :: ByteString -> ByteString
+    changePath _ = TE.encodeUtf8 $ "/p/" <> frameId <> "#/"
 
-    microSrvSettings :: MicroServicesSettings
-    microSrvSettings = env ^. env_settings . microservicesSettings
+-- Generic server forwarder
+proxyPassServer :: Env -> ServerT Raw m
+proxyPassServer env = defaultForwardServer id env
 
-    pxyPort :: Int
-    pxyPort = microSrvSettings ^. msProxyPort
 
-    writeFrameURL :: T.Text
-    writeFrameURL = env ^. hasConfig . gc_frame_write_url
+mkProxyDestination :: Env -> ProxyDestination
+mkProxyDestination env = fromMaybe (panicTrace "Invalid URI found in the proxied Request.") $ do
+  URI{..} <- URI.parseURI (T.unpack $ env ^. hasConfig . gc_frame_write_url)
+  uriAut  <- uriAuthority
+  port    <- case uriPort uriAut of
+    "" -> pure 80
+    xs -> readMaybe (dropWhile (==':') xs)
+  pure $ ProxyDestination (C8.pack uriScheme) (C8.pack $ uriRegName uriAut) port
 
-    assetPath :: B.ByteString
-    assetPath
-      | snd forwardedHost /= 80
-      = TE.encodeUtf8 $ writeFrameURL <> ":" <> T.pack (Prelude.show $ snd forwardedHost)
-      | otherwise
-      = TE.encodeUtf8 writeFrameURL
+--
+-- Combinators over the input Request
+--
 
-    removeProxyPath :: ByteString -> ByteString
-    removeProxyPath = TE.encodeUtf8
-                    . T.replace "/notes-proxy" ""
-                    . TE.decodeUtf8
+removeProxyPath :: T.Text -> Request -> Request
+removeProxyPath pth originalRequest =
+  originalRequest { rawPathInfo = removePath (rawPathInfo originalRequest) }
+  where
+    removePath :: ByteString -> ByteString
+    removePath = TE.encodeUtf8 . T.replace pth "" . TE.decodeUtf8
 
-    proxySettings :: WaiProxySettings
-    proxySettings = defaultWaiProxySettings { wpsProcessBody = \_req _res -> Just replaceRelativeLinks
-                                            , wpsModifyResponseHeaders = \_req _res -> tweakResponseHeaders
-                                            }
 
-    replaceRelativeLinks :: ConduitT B.ByteString (Flush Builder) IO ()
-    replaceRelativeLinks = CC.map (flushReplace assetPath)
-      where
+defaultForwardServer :: (Request -> Request) -> Env -> ServerT Raw m
+defaultForwardServer presendModifyRequest env =
+  Tagged $ waiProxyToSettings forwardRequest (proxySettings $ mkProxyDestination env) (env ^. env_manager)
+  where
 
-    noCache :: RequestHeaders -> RequestHeaders
-    noCache hdrs = (hCacheControl, fromString "no-cache") :
-      filter ((/=) hCacheControl . fst) hdrs
+    proxyDestination :: ProxyDestination
+    proxyDestination = mkProxyDestination env
 
-    newHost :: RequestHeaders -> RequestHeaders
-    newHost hdrs =
-      (hHost, fromString $ fst forwardedHost <> ":" <> Prelude.show (snd forwardedHost)) :
-      filter ((/=) hHost . fst) hdrs
+    microSrvSettings :: MicroServicesSettings
+    microSrvSettings = env ^. env_settings . microservicesSettings
+
+    proxyListeningPort :: Int
+    proxyListeningPort = microSrvSettings ^. msProxyPort
+
+    proxySettings :: ProxyDestination -> WaiProxySettings
+    proxySettings h@ProxyDestination{..} =
+      defaultWaiProxySettings { wpsProcessBody = \_req _res -> Just $ replaceRelativeLinks assetPath
+                              , wpsModifyResponseHeaders = \_req _res -> tweakResponseHeaders
+                              }
+      where
+        assetPath :: B.ByteString
+        assetPath
+          | fwdPort /= 80
+          = renderProxyDestination h
+          | otherwise
+          = fwdProto <> "//" <> fwdHost
+
+    newHost :: ProxyDestination -> RequestHeaders -> RequestHeaders
+    newHost hst hdrs = (hHost, renderProxyDestination hst) : filter ((/=) hHost . fst) hdrs
 
     newReferer :: RequestHeaders -> RequestHeaders
     newReferer hdrs =
-      (hReferer, fromString $ "http://localhost:" <> Prelude.show pxyPort) :
+      (hReferer, fromString $ "http://localhost:" <> Prelude.show proxyListeningPort) :
       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 = (newReferer . newHost . noCache $ (requestHeaders originalRequest))
+      let proxiedReq = presendModifyRequest $ originalRequest {
+                         requestHeaders = (newReferer . newHost proxyDestination . noCache $ (requestHeaders originalRequest))
                          }
-      pure $ WPRModifiedRequest proxiedReq mkProxyDest
+      pure $ WPRModifiedRequest proxiedReq ProxyDest (fwdHost proxyDestination) (fwdPort proxyDestination))
 
+--
+-- Utility functions
+--
+
+noCache :: RequestHeaders -> RequestHeaders
+noCache hdrs = (hCacheControl, fromString "no-cache") : filter ((/=) hCacheControl . fst) hdrs
+
+-- | Tweak the response headers so that they will have a bit more permissive
+-- 'Content-Security-Policy'.
 tweakResponseHeaders :: ResponseHeaders -> ResponseHeaders
 tweakResponseHeaders = Prelude.map tweakHeader
   where
@@ -161,17 +190,21 @@ tweakResponseHeaders = Prelude.map tweakHeader
       | otherwise
       = (k,v)
 
--- | Replaces the relative links in the proxied page content with proper urls.
-flushReplace :: B.ByteString -> B.ByteString -> Flush Builder
-flushReplace assetPath = Chunk . byteString . replaceIt assetPath
-
-replaceIt :: B.ByteString -> B.ByteString -> B.ByteString
-replaceIt assetPath htmlBlob =
-  replaceAllCaptures ALL makeAbsolute $ htmlBlob *=~ [re|src="\/build\/|href="\/build\/|src="\/config|src="\/js\/|]
+-- | Replaces the relative links in any HTML blob returned by the proxy.
+replaceRelativeLinks :: B.ByteString -> ConduitT B.ByteString (Flush Builder) IO ()
+replaceRelativeLinks assetPath = CC.map flushReplace
   where
-    makeAbsolute _ _loc cap = case capturedText cap of
-      "src=\"/build/"  -> Just $ "src=\"" <> assetPath <> "/build/"
-      "href=\"/build/" -> Just $ "href=\"" <> assetPath <> "/build/"
-      "src=\"/config"  -> Just $ "src=\"" <> assetPath <> "/config"
-      "src=\"/js/"     -> Just $ "src=\"" <> assetPath <> "/js/"
-      _                -> Just $ assetPath <> capturedText cap
+    --  Replaces the relative links in the proxied page content with proper urls.
+    flushReplace :: B.ByteString -> Flush Builder
+    flushReplace = Chunk . byteString . replaceIt
+
+    replaceIt :: B.ByteString -> B.ByteString
+    replaceIt htmlBlob =
+      replaceAllCaptures ALL makeAbsolute $ htmlBlob *=~ [re|src="\/build\/|href="\/build\/|src="\/config|src="\/js\/|]
+      where
+        makeAbsolute _ _loc cap = case capturedText cap of
+          "src=\"/build/"  -> Just $ "src=\"" <> assetPath <> "/build/"
+          "href=\"/build/" -> Just $ "href=\"" <> assetPath <> "/build/"
+          "src=\"/config"  -> Just $ "src=\"" <> assetPath <> "/config"
+          "src=\"/js/"     -> Just $ "src=\"" <> assetPath <> "/js/"
+          _                -> Just $ assetPath <> capturedText cap