Fix project/user searches

Author: ChrisPenner

package.yaml

@@ -20,7 +20,7 @@ description:         Please see the README on GitHub at <https://github.com/gith
 ghc-options:
 - -Wall
 - -Werror
-- -Wno-name-shadowing
+- -Wname-shadowing
 - -Wno-type-defaults
 - -Wno-missing-pattern-synonym-signatures
 - -fprint-expanded-synonyms

share-api.cabal

@@ -180,7 +180,7 @@ library
       BlockArguments
       QuasiQuotes
       ImportQualifiedPost
-  ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info -O2 -funbox-strict-fields
+  ghc-options: -Wall -Werror -Wname-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info -O2 -funbox-strict-fields
   build-depends:
       Diff
     , MonadRandom
@@ -319,7 +319,7 @@ executable share-api
       BlockArguments
       QuasiQuotes
       ImportQualifiedPost
-  ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info -O2 -funbox-strict-fields -threaded -rtsopts "-with-rtsopts=-N -A32m -qn2 -T"
+  ghc-options: -Wall -Werror -Wname-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info -O2 -funbox-strict-fields -threaded -rtsopts "-with-rtsopts=-N -A32m -qn2 -T"
   build-depends:
       Diff
     , MonadRandom

src/Share/App.hs

@@ -20,11 +20,11 @@ type CloudApp = AppM ()
 
 instance Logging.MonadLogger (AppM ()) where
   logMsg msg = do
-    log <- asks Env.logger
+    log' <- asks Env.logger
     minSeverity <- asks Env.minLogSeverity
     when (Logging.severity msg >= minSeverity) $ do
       timestamp <- asks timeCache >>= liftIO
-      liftIO . log . Logging.logFmtFormatter timestamp $ msg
+      liftIO . log' . Logging.logFmtFormatter timestamp $ msg
 
 instance Cryptonite.MonadRandom (AppM reqCtx) where
   getRandomBytes =

src/Share/Postgres/Queries.hs

@@ -39,7 +39,7 @@ import Share.Web.Share.Releases.Types (ReleaseStatusFilter (..), StatusUpdate (.
 import Unison.Util.List qualified as Utils
 import Unison.Util.Monoid (intercalateMap)
 
-userByUserId :: PG.QueryM m => UserId -> m (Maybe User)
+userByUserId :: (PG.QueryM m) => UserId -> m (Maybe User)
 userByUserId uid = do
   PG.query1Row
     [PG.sql|
@@ -260,8 +260,8 @@ searchUsersByNameOrHandlePrefix (Query prefix) (Limit limit) = do
 --
 -- The PG.queryListRows accepts strings as web search queries, see
 -- https://www.postgresql.org/docs/current/textsearch-controls.html
-searchProjectsByUserQuery :: Maybe UserId -> Query -> Limit -> PG.Transaction e [(Project, UserHandle)]
-searchProjectsByUserQuery caller (Query query) limit = do
+searchProjects :: Maybe UserId -> Maybe UserId -> Query -> Limit -> PG.Transaction e [(Project, UserHandle)]
+searchProjects caller userIdFilter (Query query) limit = do
   let prefixQuery =
         query
           -- Remove any chars with special meaning for tsqueries.
@@ -280,6 +280,7 @@ searchProjectsByUserQuery caller (Query query) limit = do
         JOIN users AS owner ON p.owner_user_id = owner.id
       WHERE (webquery @@ p.project_text_document OR prefixquery @@ p.project_text_document)
       AND (NOT p.private OR (#{caller} IS NOT NULL AND EXISTS (SELECT FROM accessible_private_projects WHERE user_id = #{caller} AND project_id = p.id)))
+      AND (#{userIdFilter} IS NULL OR p.owner_user_id = #{userIdFilter})
       ORDER BY (ts_rank_cd(p.project_text_document, webquery), ts_rank_cd(p.project_text_document, prefixquery)) DESC
       LIMIT #{limit}
       |]
@@ -698,7 +699,7 @@ createBranch !_nlReceipt projectId branchName contributorId causalId mergeTarget
       |]
 
 createRelease ::
-  PG.QueryM m =>
+  (PG.QueryM m) =>
   NameLookupReceipt ->
   ProjectId ->
   ReleaseVersion ->

src/Share/Web/Share/Impl.hs

@@ -6,9 +6,11 @@
 
 module Share.Web.Share.Impl where
 
+import Data.Text qualified as Text
+import Servant
 import Share.Codebase qualified as Codebase
 import Share.Codebase.Types qualified as Codebase
-import Share.IDs (TourId, UserHandle)
+import Share.IDs (TourId, UserHandle (..))
 import Share.IDs qualified as IDs
 import Share.JWT qualified as JWT
 import Share.OAuth.Session
@@ -21,6 +23,7 @@ import Share.Postgres.Users.Queries qualified as UsersQ
 import Share.Prelude
 import Share.Project (Project (..))
 import Share.User (User (..))
+import Share.User qualified as User
 import Share.UserProfile (UserProfile (..))
 import Share.Utils.API
 import Share.Utils.Caching
@@ -35,7 +38,6 @@ import Share.Web.Share.CodeBrowsing.API (CodeBrowseAPI)
 import Share.Web.Share.Contributions.Impl qualified as Contributions
 import Share.Web.Share.Projects.Impl qualified as Projects
 import Share.Web.Share.Types
-import Servant
 import Unison.Codebase.Path qualified as Path
 import Unison.HashQualified qualified as HQ
 import Unison.Name (Name)
@@ -332,13 +334,23 @@ getUserReadmeEndpoint (AuthN.MaybeAuthedUserID callerUserId) userHandle = do
 -- all private users in the PG query itself.
 searchEndpoint :: Maybe Session -> Query -> Maybe Limit -> WebApp [SearchResult]
 searchEndpoint _caller (Query "") _limit = pure []
-searchEndpoint (MaybeAuthedUserID callerUserId) query (fromMaybe (Limit 20) -> limit) = do
+searchEndpoint (MaybeAuthedUserID callerUserId) (Query query) (fromMaybe (Limit 20) -> limit) = do
+  (userQuery :: Query, (projectUserFilter :: Maybe UserId, projectQuery :: Query)) <-
+    fromMaybe query (Text.stripPrefix "@" query)
+      & Text.splitOn "/"
+      & \case
+        (userQuery : projectQueryText : _rest) -> do
+          mayUserId <- PG.runTransaction $ fmap User.user_id <$> Q.userByHandle (UserHandle userQuery)
+          pure (Query query, (mayUserId, Query projectQueryText))
+        [projectOrUserQuery] -> pure (Query projectOrUserQuery, (Nothing, Query projectOrUserQuery))
+        -- This is impossible
+        [] -> pure (Query query, (Nothing, Query query))
   -- We don't have a great way to order users and projects together, so we just limit to a max
   -- of 5 users (who match the query as a prefix), then return the rest of the results from
   -- projects.
   (users, projects) <- PG.runTransaction $ do
-    users <- Q.searchUsersByNameOrHandlePrefix query (Limit 5)
-    projects <- Q.searchProjectsByUserQuery callerUserId query limit
+    users <- Q.searchUsersByNameOrHandlePrefix userQuery (Limit 5)
+    projects <- Q.searchProjects callerUserId projectUserFilter projectQuery limit
     pure (users, projects)
   let userResults =
         users

transcripts/share-apis/projects-flow/project-search-with-user.json

@@ -0,0 +1,15 @@
+{
+  "body": [
+    {
+      "projectRef": "@test/publictestproject",
+      "summary": "test project summary",
+      "tag": "Project",
+      "visibility": "public"
+    }
+  ],
+  "status": [
+    {
+      "status_code": 200
+    }
+  ]
+}

transcripts/share-apis/projects-flow/run.zsh

@@ -78,6 +78,9 @@ fetch "$transcript_user" GET project-catalog-get '/catalog'
 # Should find projects we have access to (e.g. Unison's private project), but none that we don't.
 fetch "$transcript_user" GET project-search '/search?query=test'
 
+# Should filter project search by user if provided a full valid handle:
+fetch "$transcript_user" GET project-search-with-user '/search?query=@test/public'
+
 # Transcript user should not find 'test' user's private project
 fetch "$transcript_user" GET project-search-inaccessible '/search?query=privatetestproject'