Share URL improvement and tests

This commit improves a bit the ShareURL internal API by wrapping the
returned URL into a proper `ShareURL` type (that internally uses a typed
representation for the URL).

gargantext.cabal

@@ -915,6 +915,7 @@ test-suite garg-test-hspec
       Test.API.Errors
       Test.API.GraphQL
       Test.API.Private
+      Test.API.Private.Share
       Test.API.Routes
       Test.API.Setup
       Test.API.UpdateList

src/Gargantext/API/Node/ShareURL.hs

@@ -3,14 +3,16 @@
 
 module Gargantext.API.Node.ShareURL where
 
-import Data.Text
-import Gargantext.Prelude
+import Control.Lens
+import Data.Text qualified as T
+import Data.Validity qualified as V
 import Gargantext.API.Prelude
-import Gargantext.Core.Types (NodeType, NodeId, unNodeId)
-import Gargantext.Database.Prelude (HasConfig (hasConfig), CmdCommon)
-import Control.Lens.Getter (view)
-import Gargantext.Core.Config (gc_url)
 import Gargantext.API.Routes.Named.Share qualified as Named
+import Gargantext.Core.Config (gc_url)
+import Gargantext.Core.Types (NodeType, NodeId, unNodeId, _ValidationError)
+import Gargantext.Database.Prelude (HasConfig (hasConfig), CmdCommon)
+import Gargantext.Prelude
+import Network.URI (parseURI)
 import Servant.Server.Generic (AsServerT)
 
 shareURL :: IsGargServer env err m => Named.ShareURL (AsServerT m)
@@ -19,14 +21,17 @@ shareURL = Named.ShareURL getUrl
 getUrl :: (IsGargServer env err m, CmdCommon env)
        => Maybe NodeType
        -> Maybe NodeId
-       -> m Text
+       -> m Named.ShareLink
 getUrl nt id = do
--- TODO add check that the node is able to be shared (in a shared folder)
-    case nt of
-        Nothing -> pure "Invalid node Type"
-        Just t ->
-            case id of
-                Nothing -> pure "Invalid node ID"
-                Just i -> do
-                    url <- view $ hasConfig . gc_url
-                    pure $ url <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
+  -- TODO add check that the node is able to be shared (in a shared folder)
+  urlHost <- T.unpack <$> view (hasConfig . gc_url)
+  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)
+        maybe (Left $ "Couldn't construct a valid share URL from '" <> rawURL <> "'")
+              (Right . Named.ShareLink)
+              (parseURI rawURL)
+  case res of
+    Left err        -> throwError $ _ValidationError # (V.check False err)
+    Right shareLink -> pure shareLink

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

@@ -92,7 +92,7 @@ data GargPrivateAPI' mode = GargPrivateAPI'
   , listGetAPI     :: mode :- NamedRoutes List.GETAPI
   , listJsonAPI    :: mode :- NamedRoutes List.JSONAPI
   , listTsvAPI     :: mode :- NamedRoutes List.TSVAPI
-  , shareUrlEp     :: mode :- "shareurl" :> NamedRoutes ShareURL
+  , shareUrlAPI    :: mode :- "shareurl" :> NamedRoutes ShareURL
   } deriving Generic
 
 

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

 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Gargantext.API.Routes.Named.Share (
   -- * Routes types
     ShareNode(..)
   , Unpublish(..)
   , ShareURL(..)
+  , ShareLink(..)
+  , renderShareLink
 
   -- * API types (which appears in the routes)
   , ShareNodeParams(..)
   ) where
 
-import Data.Text (Text)
+import Data.Aeson
+import Data.Swagger
+import Data.Text qualified as T
 import GHC.Generics
 import Gargantext.API.Node.Share.Types ( ShareNodeParams (..) )
 import Gargantext.Database.Admin.Types.Node
+import Network.URI (parseURI)
 import Prelude
 import Servant
 
+-- | A shareable link.
+-- N.B. We don't use a 'BareUrl' internally, because parsing something like
+-- 'http://localhost/#/share/NodeCorpus/16'
+-- would fail because '#/share/NodeCorpus/16' by the RFC3968 spec is considered
+-- an uriFragment, but BaseUrl cannot handle that.
+newtype ShareLink = ShareLink { getShareLink :: URI }
+  deriving (Show, Eq, Ord)
+
+renderShareLink :: ShareLink -> T.Text
+renderShareLink = T.pack . show . getShareLink
+
+instance ToJSON ShareLink where
+  toJSON = toJSON . renderShareLink
+
+instance FromJSON ShareLink where
+  parseJSON = withText "ShareLink" $ \txt ->
+    let urlStr = T.unpack txt
+    in case parseURI urlStr of
+          Nothing -> fail $ "Invalid URL: " <> urlStr
+          Just u  -> pure $ ShareLink u
+
+instance ToSchema ShareLink where
+  declareNamedSchema _ = declareNamedSchema (Proxy @T.Text)
 
 newtype ShareURL mode = ShareURL
   { shareUrlEp :: mode :- Summary "Fetch URL for sharing a node"
                        :> QueryParam "type" NodeType
                        :> QueryParam "id" NodeId
-                       :> Get '[JSON] Text
+                       :> Get '[JSON] ShareLink
   } deriving Generic
 
 

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

@@ -63,5 +63,5 @@ serverPrivateGargAPI' authenticatedUser@(AuthenticatedUser userNodeId userId)
        , listGetAPI        = List.getAPI
        , listJsonAPI       = List.jsonAPI
        , listTsvAPI        = List.tsvAPI
-       , shareUrlEp        = shareURL
+       , shareUrlAPI       = shareURL
        }

test/Test/API/Private.hs

@@ -7,29 +7,29 @@ module Test.API.Private (
     tests
   ) where
 
+import Gargantext.API.Routes.Named.Node
+import Gargantext.API.Routes.Named.Private
+import Gargantext.Core.Types (Node)
 import Gargantext.Core.Types.Individu
+import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
 import Gargantext.Prelude hiding (get)
 import Network.HTTP.Client hiding (Proxy)
+import Network.Wai
 import Servant.Auth.Client ()
 import Servant.Client
+import Servant.Client.Generic (genericClient)
+import Test.API.Private.Share qualified as Share
 import Test.API.Routes (mkUrl)
 import Test.API.Setup (withTestDBAndPort, setupEnvironment, createAliceAndBob)
+import Test.Database.Types
 import Test.Hspec
 import Test.Hspec.Wai hiding (pendingWith)
 import Test.Hspec.Wai.Internal (withApplication)
 import Test.Hspec.Wai.JSON (json)
 import Test.Utils (protected, shouldRespondWithFragment, withValidLogin)
-import Gargantext.API.Routes.Named.Private
-import Gargantext.Core.Types (Node)
-import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
-import Servant.Client.Generic (genericClient)
-import Gargantext.API.Routes.Named.Node
 
-
-tests :: Spec
-tests = sequential $ aroundAll withTestDBAndPort $ do
-  describe "Prelude" $ do
-    it "setup DB triggers" $ \((testEnv, _), _) -> setupEnvironment testEnv
+privateTests :: SpecWith ((TestEnv, Int), Application)
+privateTests =
   describe "Private API" $ do
     baseUrl <- runIO $ parseBaseUrl "http://localhost"
     manager <- runIO $ newManager defaultManagerSettings
@@ -90,3 +90,13 @@ tests = sequential $ aroundAll withTestDBAndPort $ do
         withApplication app $ do
           withValidLogin port "alice" (GargPassword "alice") $ \token -> do
             protected token "GET" (mkUrl port "/tree/1") "" `shouldRespondWith` 403
+
+
+tests :: Spec
+tests = do
+  sequential $ aroundAll withTestDBAndPort $ do
+    describe "Prelude" $ do
+      it "setup DB triggers" $ \((testEnv, _), _) -> setupEnvironment testEnv
+    privateTests
+  describe "Share API" $ do
+    Share.tests

test/Test/API/Private/Share.hs

+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Test.API.Private.Share (
+    tests
+  ) where
+
+import Control.Lens
+import Data.ByteString.Lazy.Char8 qualified as CL8
+import Data.List qualified as T
+import Gargantext.API.Errors
+import Gargantext.API.Routes.Named
+import Gargantext.API.Routes.Named.Private
+import Gargantext.API.Routes.Named.Share
+import Gargantext.Core.Types
+import Gargantext.Core.Types.Individu
+import Gargantext.Prelude
+import Network.HTTP.Client hiding (responseBody)
+import Prelude (fail)
+import Servant.Auth.Client qualified as SC
+import Servant.Client
+import Test.API.Routes
+import Test.API.Setup
+import Test.API.UpdateList (newCorpusForUser)
+import Test.Hspec
+import Test.Hspec.Wai.Internal (withApplication)
+import Test.Utils
+
+shareURL :: SC.Token -> Maybe NodeType -> Maybe NodeId -> ClientM ShareLink
+shareURL token =
+  clientRoutes & apiWithCustomErrorScheme
+               & ($ GES_new)
+               & backendAPI
+               & backendAPI'
+               & mkBackEndAPI
+               & gargAPIVersion
+               & gargPrivateAPI
+               & mkPrivateAPI
+               & ($ token)
+               & shareUrlAPI
+               & shareUrlEp
+
+tests :: Spec
+tests = sequential $ aroundAll withTestDBAndPort $ do
+  describe "Prelude" $ do
+    it "setup DB triggers" $ \((testEnv, _), _) -> do
+      setupEnvironment testEnv
+      -- Let's create the Alice user.
+      createAliceAndBob testEnv
+
+    baseUrl <- runIO $ parseBaseUrl "http://localhost"
+    manager <- runIO $ newManager defaultManagerSettings
+    let clientEnv port = mkClientEnv manager (baseUrl { baseUrlPort = port })
+
+    it "should fail if no node type is specified" $ \((_testEnv, serverPort), app) -> do
+      withApplication app $ do
+        withValidLogin serverPort "alice" (GargPassword "alice") $ \token -> 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")
+            _ -> fail "Test did not fail as expected!"
+
+    it "should fail if no node ID is specified" $ \((_testEnv, serverPort), app) -> do
+      withApplication app $ do
+        withValidLogin serverPort "alice" (GargPassword "alice") $ \token -> 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")
+            _ -> fail "Test did not fail as expected!"
+
+    it "should return a valid URL" $ \((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 _)
+              -> pure ()