Merge in project-search fixes

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

@@ -192,7 +192,7 @@ library
       QuasiQuotes
       ImportQualifiedPost
       OverloadedRecordDot
-  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
@@ -335,7 +335,7 @@ executable share-api
       QuasiQuotes
       ImportQualifiedPost
       OverloadedRecordDot
-  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

@@ -27,11 +27,11 @@ runAppM env (AppM m) = runReaderT m env
 
 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

@@ -274,8 +274,24 @@ 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)]
+-- Don't search with an empty query
+searchProjects _caller Nothing (Query "") _limit = pure []
+searchProjects caller (Just userId) (Query "") limit = do
+  -- If we have a userId filter but no query, just return all the projects owned by that user
+  -- which the caller has access to.
+  PG.queryListRows @(Project PG.:. PG.Only UserHandle)
+    [PG.sql|
+    SELECT p.id, p.owner_user_id, p.slug, p.summary, p.tags, p.private, p.created_at, p.updated_at, owner.handle
+      FROM projects p
+        JOIN users owner ON p.owner_user_id = owner.id
+      WHERE p.owner_user_id = #{userId}
+        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)))
+      ORDER BY p.created_at DESC
+      LIMIT #{limit}
+      |]
+    <&> fmap \(project PG.:. PG.Only handle) -> (project, handle)
+searchProjects caller userIdFilter (Query query) limit = do
   let prefixQuery =
         query
           -- Remove any chars with special meaning for tsqueries.
@@ -294,6 +310,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}
       |]

src/Share/Web/Share/Impl.hs

@@ -6,11 +6,12 @@
 
 module Share.Web.Share.Impl where
 
-import Control.Lens
+import Data.Text qualified as Text
 import Servant
+import Control.Lens
 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
@@ -27,6 +28,7 @@ import Share.Prelude
 import Share.Project (Project (..))
 import Share.Release (Release (..))
 import Share.User (User (..))
+import Share.User qualified as User
 import Share.UserProfile (UserProfile (..))
 import Share.Utils.API
 import Share.Utils.Caching
@@ -340,13 +342,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-only-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/project-search-with-user-and-project-query.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,12 @@ 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-and-project-query '/search?query=@test/public'
+
+# Should return all projects in a user if provided a full valid handle, but no project query:
+fetch "$transcript_user" GET project-search-with-only-user '/search?query=@test/'
+
 # Transcript user should not find 'test' user's private project
 fetch "$transcript_user" GET project-search-inaccessible '/search?query=privatetestproject'