Merge pull request #5553 from unisonweb/cp/project-list-updates

Project List API updates for UCM Desktop
unisonweb · Jan 24, 2025 · f605cec · f605cec
2 parents 0642fc3 + 5d2aa19
commit f605cec
Show file tree

Hide file tree

Showing 16 changed files with 242 additions and 101 deletions.
diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs
@@ -256,6 +256,7 @@ module U.Codebase.Sqlite.Queries
     addCurrentProjectPathTable,
     addProjectBranchReflogTable,
     addProjectBranchCausalHashIdColumn,
+    addProjectBranchLastAccessedColumn,
 
     -- ** schema version
     currentSchemaVersion,
@@ -420,7 +421,7 @@ type TextPathSegments = [Text]
 -- * main squeeze
 
 currentSchemaVersion :: SchemaVersion
-currentSchemaVersion = 17
+currentSchemaVersion = 18
 
 runCreateSql :: Transaction ()
 runCreateSql =
@@ -486,6 +487,10 @@ addProjectBranchCausalHashIdColumn :: Transaction ()
 addProjectBranchCausalHashIdColumn =
   executeStatements $(embedProjectStringFile "sql/014-add-project-branch-causal-hash-id.sql")
 
+addProjectBranchLastAccessedColumn :: Transaction ()
+addProjectBranchLastAccessedColumn =
+  executeStatements $(embedProjectStringFile "sql/015-add-project-branch-last-accessed.sql")
+
 schemaVersion :: Transaction SchemaVersion
 schemaVersion =
   queryOneCol
@@ -2274,32 +2279,6 @@ globEscape =
     ']' -> "[]]"
     c -> Text.singleton c
 
--- | Escape special characters for "LIKE" matches.
---
--- Prepared statements prevent sql injection, but it's still possible some user
--- may be able to craft a query using a fake "hash" that would let them see more than they
--- ought to.
---
--- You still need to provide the escape char in the sql query, E.g.
---
--- @@
---   SELECT * FROM table
---     WHERE txt LIKE ? ESCAPE '\'
--- @@
---
--- >>> likeEscape '\\' "Nat.%"
--- "Nat.\%"
-likeEscape :: Char -> Text -> Text
-likeEscape '%' _ = error "Can't use % or _ as escape characters"
-likeEscape '_' _ = error "Can't use % or _ as escape characters"
-likeEscape escapeChar pat =
-  flip Text.concatMap pat \case
-    '%' -> Text.pack [escapeChar, '%']
-    '_' -> Text.pack [escapeChar, '_']
-    c
-      | c == escapeChar -> Text.pack [escapeChar, escapeChar]
-      | otherwise -> Text.singleton c
-
 -- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this
 -- is only true on Share.
 --
@@ -4484,6 +4463,13 @@ setCurrentProjectPath projId branchId path = do
       INSERT INTO current_project_path(project_id, branch_id, path)
       VALUES (:projId, :branchId, :jsonPath)
     |]
+  execute
+    [sql|
+      UPDATE project_branch
+      SET last_accessed = strftime('%s', 'now')
+      WHERE project_id = :projId
+        AND branch_id = :branchId
+    |]
   where
     jsonPath :: Text
     jsonPath =

diff --git a/codebase2/codebase-sqlite/sql/015-add-project-branch-last-accessed.sql b/codebase2/codebase-sqlite/sql/015-add-project-branch-last-accessed.sql
@@ -0,0 +1,3 @@
+-- Add a new column to the project_branch table to store the last time that project branch was accessed.
+-- This column is stored as a unix epoch time.
+ALTER TABLE project_branch ADD COLUMN last_accessed INTEGER NULL;
diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal
@@ -24,6 +24,7 @@ extra-source-files:
     sql/012-add-current-project-path-table.sql
     sql/013-add-project-branch-reflog-table.sql
     sql/014-add-project-branch-causal-hash-id.sql
+    sql/015-add-project-branch-last-accessed.sql
     sql/create.sql
 
 source-repository head

diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs
@@ -56,6 +56,9 @@ module Unison.Sqlite
     queryOneRowCheck,
     queryOneColCheck,
 
+    -- * Utilities
+    likeEscape,
+
     -- * Rows modified
     rowsModified,
 
@@ -119,6 +122,7 @@ import Unison.Sqlite.Exception
 import Unison.Sqlite.JournalMode (JournalMode (..), SetJournalModeException (..), trySetJournalMode)
 import Unison.Sqlite.Sql (Sql, sql)
 import Unison.Sqlite.Transaction
+import Unison.Sqlite.Utils (likeEscape)
 
 -- $query-naming-convention
 --

diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Utils.hs b/lib/unison-sqlite/src/Unison/Sqlite/Utils.hs
@@ -0,0 +1,30 @@
+module Unison.Sqlite.Utils (likeEscape) where
+
+import Data.Text (Text)
+import Data.Text qualified as Text
+
+-- | Escape special characters for "LIKE" matches.
+--
+-- Prepared statements prevent sql injection, but it's still possible some user
+-- may be able to craft a query using a fake "hash" that would let them see more than they
+-- ought to.
+--
+-- You still need to provide the escape char in the sql query, E.g.
+--
+-- @@
+--   SELECT * FROM table
+--     WHERE txt LIKE ? ESCAPE '\'
+-- @@
+--
+-- >>> likeEscape '\\' "Nat.%"
+-- "Nat.\%"
+likeEscape :: Char -> Text -> Text
+likeEscape '%' _ = error "Can't use % or _ as escape characters"
+likeEscape '_' _ = error "Can't use % or _ as escape characters"
+likeEscape escapeChar pat =
+  flip Text.concatMap pat \case
+    '%' -> Text.pack [escapeChar, '%']
+    '_' -> Text.pack [escapeChar, '_']
+    c
+      | c == escapeChar -> Text.pack [escapeChar, escapeChar]
+      | otherwise -> Text.singleton c
diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal
@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.36.0.
+-- This file has been generated from package.yaml by hpack version 0.37.0.
 --
 -- see: https://github.com/sol/hpack
 
@@ -27,6 +27,7 @@ library
       Unison.Sqlite.Exception
       Unison.Sqlite.JournalMode
       Unison.Sqlite.Sql
+      Unison.Sqlite.Utils
   hs-source-dirs:
       src
   default-extensions:

diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs
@@ -84,7 +84,8 @@ migrations regionVar getDeclType termBuffer declBuffer rootCodebasePath =
       sqlMigration 14 Q.addSquashResultTable,
       sqlMigration 15 Q.addSquashResultTableIfNotExists,
       sqlMigration 16 Q.cdToProjectRoot,
-      (17 {- This migration takes a raw sqlite connection -}, \conn -> migrateSchema16To17 conn)
+      (17 {- This migration takes a raw sqlite connection -}, \conn -> migrateSchema16To17 conn),
+      sqlMigration 18 Q.addProjectBranchLastAccessedColumn
     ]
   where
     runT :: Sqlite.Transaction () -> Sqlite.Connection -> IO ()

diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema16To17.hs
@@ -5,9 +5,11 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema16To17 (migrateSch
 
 import Control.Lens
 import Data.Aeson qualified as Aeson
+import Data.Aeson.Text qualified as Aeson
 import Data.Map qualified as Map
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
+import Data.Text.Lazy qualified as Text.Lazy
 import Data.UUID (UUID)
 import Data.UUID qualified as UUID
 import U.Codebase.Branch.Type qualified as V2Branch
@@ -76,8 +78,8 @@ migrateSchema16To17 conn = withDisabledForeignKeys $ do
 
   case mayRecentProjectBranch of
     Just (projectId, branchId) ->
-      Q.setCurrentProjectPath projectId branchId []
-    Nothing -> Q.setCurrentProjectPath scratchMain.projectId scratchMain.branchId []
+      initializeCurrentProjectPath projectId branchId []
+    Nothing -> initializeCurrentProjectPath scratchMain.projectId scratchMain.branchId []
   Debug.debugLogM Debug.Migration "Done migrating to version 17"
   Q.setSchemaVersion 17
   where
@@ -89,6 +91,19 @@ migrateSchema16To17 conn = withDisabledForeignKeys $ do
       let enable = Connection.execute conn [Sqlite.sql| PRAGMA foreign_keys=ON |]
       let action = Sqlite.runWriteTransaction conn \run -> run $ m
       UnsafeIO.bracket disable (const enable) (const action)
+    initializeCurrentProjectPath :: ProjectId -> ProjectBranchId -> [NameSegment] -> Sqlite.Transaction ()
+    initializeCurrentProjectPath projId branchId path = do
+      Sqlite.execute
+        [Sqlite.sql| DELETE FROM current_project_path |]
+      Sqlite.execute
+        [Sqlite.sql|
+          INSERT INTO current_project_path(project_id, branch_id, path)
+          VALUES (:projId, :branchId, :jsonPath)
+        |]
+      where
+        jsonPath :: Text
+        jsonPath =
+          Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> path)
 
 data ForeignKeyFailureException
   = ForeignKeyFailureException

diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs
@@ -96,6 +96,7 @@ createSchema = do
   Q.addCurrentProjectPathTable
   Q.addProjectBranchReflogTable
   Q.addProjectBranchCausalHashIdColumn
+  Q.addProjectBranchLastAccessedColumn
   (_, emptyCausalHashId) <- emptyCausalHash
   (_, ProjectBranch {projectId, branchId}) <- insertProjectAndBranch scratchProjectName scratchBranchName emptyCausalHashId
   Q.setCurrentProjectPath projectId branchId []

diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml
@@ -121,3 +121,4 @@ default-extensions:
   - TypeOperators
   - ViewPatterns
   - ImportQualifiedPost
+  - QuasiQuotes
diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/Projects.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/Projects.hs
@@ -11,9 +11,7 @@ module Unison.Server.Local.Endpoints.Projects
   )
 where
 
-import Data.Aeson (ToJSON (..))
-import Data.Aeson qualified as Aeson
-import Data.OpenApi (ToParamSchema, ToSchema)
+import Data.OpenApi (ToParamSchema)
 import GHC.Generics ()
 import Servant
 import Servant.Docs
@@ -22,48 +20,21 @@ import U.Codebase.Sqlite.Project qualified as SqliteProject
 import U.Codebase.Sqlite.Queries qualified as Q
 import Unison.Codebase (Codebase)
 import Unison.Codebase qualified as Codebase
-import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName), ProjectName (UnsafeProjectName))
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
+import Unison.Project (ProjectName)
 import Unison.Server.Backend (Backend)
+import Unison.Server.Local.Endpoints.Projects.Queries qualified as PG
+import Unison.Server.Local.Endpoints.Projects.Queries qualified as PQ
+import Unison.Server.Local.Endpoints.Projects.Types
 import Unison.Symbol (Symbol)
 
-data ProjectListing = ProjectListing
-  { projectName :: ProjectName
-  }
-  deriving stock (Show, Generic)
-
-instance ToSchema ProjectListing
-
-instance ToJSON ProjectListing where
-  toJSON ProjectListing {projectName} =
-    Aeson.object ["projectName" Aeson..= projectName]
-
-instance ToSample ProjectListing where
-  toSamples _ =
-    singleSample $ ProjectListing (UnsafeProjectName "my-project")
-
-data ProjectBranchListing = ProjectBranchListing
-  { branchName :: ProjectBranchName
-  }
-  deriving stock (Show, Generic)
-
-instance ToSchema ProjectBranchListing
-
-instance ToJSON ProjectBranchListing where
-  toJSON ProjectBranchListing {branchName} =
-    Aeson.object ["branchName" Aeson..= branchName]
-
-instance ToSample ProjectBranchListing where
-  toSamples _ =
-    singleSample $ ProjectBranchListing (UnsafeProjectBranchName "my-branch")
-
 type ListProjectsEndpoint =
-  QueryParam "prefix" PrefixFilter
+  QueryParam "query" Query
     :> Get '[JSON] [ProjectListing]
 
 type ListProjectBranchesEndpoint =
-  QueryParam "prefix" PrefixFilter
+  QueryParam "query" Query
     :> Get '[JSON] [ProjectBranchListing]
 
 newtype PrefixFilter = PrefixFilter
@@ -86,20 +57,39 @@ instance Docs.ToSample PrefixFilter where
   toSamples _ =
     singleSample $ PrefixFilter "my-proj"
 
+newtype Query = Query
+  { getQuery :: Text
+  }
+  deriving stock (Show, Generic)
+  deriving newtype (FromHttpApiData)
+
+instance ToParamSchema Query
+
+instance ToParam (QueryParam "query" Query) where
+  toParam _ =
+    DocQueryParam
+      "query"
+      ["my-proj"]
+      "Filter for results containing the given text."
+      Normal
+
+instance Docs.ToSample Query where
+  toSamples _ =
+    singleSample $ Query "my-proj"
+
 projectListingEndpoint ::
   Codebase IO Symbol Ann ->
-  Maybe PrefixFilter ->
+  -- Infix Query
+  Maybe Query ->
   Backend IO [ProjectListing]
-projectListingEndpoint codebase mayPrefix = liftIO . Codebase.runTransaction codebase $ do
-  projects <- Q.loadAllProjectsBeginningWith (prefix <$> mayPrefix)
-  pure $ ProjectListing . SqliteProject.name <$> projects
+projectListingEndpoint codebase mayQuery = liftIO . Codebase.runTransaction codebase $ do
+  PQ.listProjects (getQuery <$> mayQuery)
 
 projectBranchListingEndpoint ::
   Codebase IO Symbol Ann ->
   ProjectName ->
-  Maybe PrefixFilter ->
+  Maybe Query ->
   Backend IO [ProjectBranchListing]
-projectBranchListingEndpoint codebase projectName mayPrefix = liftIO . Codebase.runTransaction codebase . fmap fold . runMaybeT $ do
+projectBranchListingEndpoint codebase projectName mayQuery = liftIO . Codebase.runTransaction codebase . fmap fold . runMaybeT $ do
   SqliteProject.Project {projectId} <- MaybeT $ Q.loadProjectByName projectName
-  lift (Q.loadAllProjectBranchesBeginningWith projectId (prefix <$> mayPrefix))
-    <&> fmap (ProjectBranchListing . snd)
+  lift (PG.listProjectBranches projectId (getQuery <$> mayQuery))
diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/Projects/Queries.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/Projects/Queries.hs
@@ -0,0 +1,39 @@
+module Unison.Server.Local.Endpoints.Projects.Queries
+  ( listProjects,
+    listProjectBranches,
+  )
+where
+
+import Data.Text (Text)
+import U.Codebase.Sqlite.DbId (ProjectId)
+import Unison.Server.Local.Endpoints.Projects.Types
+import Unison.Sqlite
+
+-- | Load all project listings, optionally requiring an infix match with a query.
+listProjects :: Maybe Text -> Transaction [ProjectListing]
+listProjects mayUnsafeQuery = do
+  let mayQuery = fmap (likeEscape '\\') mayUnsafeQuery
+  queryListRow
+    [sql|
+      SELECT project.name, branch.name
+      FROM project
+        LEFT JOIN most_recent_branch mrb
+          ON project.id = mrb.project_id
+        LEFT JOIN project_branch branch
+          ON mrb.branch_id = branch.branch_id
+        WHERE (:mayQuery IS NULL OR project.name LIKE '%' || :mayQuery || '%' ESCAPE '\')
+      ORDER BY branch.last_accessed DESC NULLS LAST, project.name ASC
+    |]
+
+-- | Load all project listings, optionally requiring an infix match with a query.
+listProjectBranches :: ProjectId -> Maybe Text -> Transaction [ProjectBranchListing]
+listProjectBranches projectId mayUnsafeQuery = do
+  let mayQuery = fmap (likeEscape '\\') mayUnsafeQuery
+  queryListRow
+    [sql|
+        SELECT project_branch.name
+        FROM project_branch
+        WHERE project_branch.project_id = :projectId
+          AND (:mayQuery IS NULL OR project_branch.name LIKE '%' || :mayQuery || '%' ESCAPE '\')
+        ORDER BY project_branch.last_accessed DESC NULLS LAST, project_branch.name ASC
+      |]