Support port in share URL if localhost

src/Gargantext/API/Node/ShareURL.hs

 {-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE BangPatterns #-}
 
 module Gargantext.API.Node.ShareURL where
 
@@ -14,6 +15,7 @@ import Gargantext.Database.Prelude (HasConfig (hasConfig), CmdCommon)
 import Gargantext.Prelude
 import Network.URI (parseURI)
 import Servant.Server.Generic (AsServerT)
+import Gargantext.API.Admin.Types (appPort, settings)
 
 shareURL :: IsGargServer env err m => Named.ShareURL (AsServerT m)
 shareURL = Named.ShareURL getUrl
@@ -25,10 +27,18 @@ getUrl :: (IsGargServer env err m, CmdCommon env)
 getUrl nt id = do
   -- TODO add check that the node is able to be shared (in a shared folder)
   urlHost <- T.unpack <$> view (hasConfig . gc_url)
+  urlPort <- view (settings . appPort)
   let res = do
         t <- maybe (Left "Invalid node Type") Right nt
         i <- maybe (Left "Invalid node ID")   Right id
-        let rawURL = urlHost <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
+
+        -- Include the port the server is running on if this is
+        -- localhost, so that share URLs would work out of the box.
+        let !rawURL
+              | "localhost" `isInfixOf` urlHost
+              = urlHost <> ":" <> show urlPort <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
+              | otherwise
+              = urlHost <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
         maybe (Left $ "Couldn't construct a valid share URL from '" <> rawURL <> "'")
               (Right . Named.ShareLink)
               (parseURI rawURL)

test/Test/API/Private/Share.hs

@@ -8,7 +8,7 @@ module Test.API.Private.Share (
 
 import Control.Lens
 import Data.ByteString.Lazy.Char8 qualified as CL8
-import Data.List qualified as T
+import Data.Text qualified as T
 import Gargantext.API.Errors
 import Gargantext.API.Routes.Named
 import Gargantext.API.Routes.Named.Private
@@ -59,7 +59,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
           url <- liftIO $ runClientM (shareURL (toServantToken token) Nothing Nothing) (clientEnv serverPort)
           case url of
             Left (FailureResponse _req res)
-              -> liftIO $ (CL8.unpack $ responseBody res) `shouldSatisfy` (T.isInfixOf "Invalid node Type")
+              -> liftIO $ (CL8.unpack $ responseBody res) `shouldSatisfy` (T.isInfixOf "Invalid node Type" . T.pack)
             _ -> fail "Test did not fail as expected!"
 
     it "should fail if no node ID is specified" $ \((_testEnv, serverPort), app) -> do
@@ -68,7 +68,7 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
           url <- liftIO $ runClientM (shareURL (toServantToken token) (Just NodeCorpus) Nothing) (clientEnv serverPort)
           case url of
             Left (FailureResponse _req res)
-              -> liftIO $ (CL8.unpack $ responseBody res) `shouldSatisfy` (T.isInfixOf "Invalid node ID")
+              -> liftIO $ (CL8.unpack $ responseBody res) `shouldSatisfy` (T.isInfixOf "Invalid node ID" . T.pack)
             _ -> fail "Test did not fail as expected!"
 
     it "should return a valid URL" $ \((testEnv, serverPort), app) -> do
@@ -81,3 +81,14 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
               -> fail (show err)
             Right (ShareLink _)
               -> pure ()
+
+    it "should include the port if needed (like localhost)" $ \((testEnv, serverPort), app) -> do
+      withApplication app $ do
+        withValidLogin serverPort "alice" (GargPassword "alice") $ \token -> do
+          cId <- liftIO $ newCorpusForUser testEnv "alice"
+          url <- liftIO $ runClientM (shareURL (toServantToken token) (Just NodeCorpus) (Just cId)) (clientEnv serverPort)
+          case url of
+            Left err
+              -> fail (show err)
+            Right (ShareLink uri)
+              -> liftIO $ "localhost:80" `T.isInfixOf` T.pack (show uri) `shouldBe` True