From a7267537fd9f431fce786a9f921756b40347482d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 20 Nov 2025 11:39:04 -0800 Subject: [PATCH 01/38] Add Schema for synced comments --- sql/2025-11-20_history-comments.sql | 77 +++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) create mode 100644 sql/2025-11-20_history-comments.sql diff --git a/sql/2025-11-20_history-comments.sql b/sql/2025-11-20_history-comments.sql new file mode 100644 index 00000000..ca58373c --- /dev/null +++ b/sql/2025-11-20_history-comments.sql @@ -0,0 +1,77 @@ +CREATE TABLE personal_keys ( + id SERIAL PRIMARY KEY, + -- The public JWK for this key. + -- This may be null if the key is not yet registered. + public_jwk jsonb NULL, + thumbprint TEXT UNIQUE NOT NULL, + -- The user registered to this key, which is proven by providing a signed + -- assertion using the key. + -- It may be null if the key is not yet registered to a user. + user_id INTEGER NULL REFERENCES users(id) ON DELETE SET NULL, + created_at TIMESTAMPTZ NOT NULL, + + -- Ensure that public_jwk and user_id are either both null or both non-null. + CHECK (public_jwk IS NULL = user_id IS NULL) +); + +CREATE INDEX idx_personal_keys_user_id ON personal_keys(user_id, created_at) + WHERE user_id IS NOT NULL; +CREATE INDEX idx_personal_keys_thumbprint ON personal_keys(thumbprint) INCLUDE (user_id); + +CREATE TABLE history_comments ( + id SERIAL PRIMARY KEY, + causal_id INTEGER NOT NULL REFERENCES causals(id), + author TEXT NOT NULL, + + -- Milliseconds since epoch, + -- This is stored as an exact integer rather than a TIMESTAMPTZ because we want + -- to avoid floating point slop since it's used in hashing. + created_at_ms BIGINT NOT NULL, + + -- This is the time we inserted the comment into our database, + -- NOT the time the comment was created by the author. + discovered_at TIMESTAMPTZ NOT NULL DEFAULT NOW(), + + -- The Hash of the comment, SHA-512 over (hashing_version, causal_id, author, created_at_ms) + comment_hash TEXT UNIQUE NOT NULL, + author_key_id INTEGER NOT NULL REFERENCES personal_keys(id) +); + +CREATE INDEX idx_history_comments_causal_id ON history_comments(causal_id); + +CREATE TABLE history_comment_revisions ( + id INTEGER PRIMARY KEY, + comment_id INTEGER NOT NULL REFERENCES history_comments(id), + subject TEXT NOT NULL, + contents TEXT NOT NULL, + + created_at_ms BIGINT NOT NULL, + + -- This is the time we inserted the comment revision into our database, + -- NOT the time the comment revision was created by the author. + discovered_at TIMESTAMPTZ NOT NULL DEFAULT NOW(), + + -- In a distributed system you really can’t ever truly delete comments, + -- but you can ask to hide them. + hidden BOOL NOT NULL DEFAULT FALSE, + + -- The Hash of the comment revision, SHA-512 over the canonical CBOR encoding of (hashing_version, comment-hash, subject, content, hidden, created_at_ms) + revision_hash TEXT UNIQUE NOT NULL, + + -- The signature of the comment's author on the revision hash. + author_signature BLOB NOT NULL +); + +CREATE INDEX idx_history_comment_revisions_comment_id ON history_comment_revisions(comment_id, created_at_ms DESC); + +-- Tracks when each comment was discovered by each project, which allows us to +-- use a simple timestamp-based approach to filter for new comments since last sync +-- on a given project. +CREATE TABLE history_comment_revisions_project_discovery ( + comment_revision_id INTEGER NOT NULL REFERENCES history_comment_revisions(id), + project_id INTEGER NOT NULL REFERENCES projects(id), + discovered_at TIMESTAMPTZ NOT NULL DEFAULT NOW(), + PRIMARY KEY (project_id, comment_revision_id) +); + +CREATE INDEX idx_history_comment_revisions_project_discovery_project_id ON history_comment_revisions_project_discovery(project_id, discovered_at); From 3ee61ce82640e9576453b8806d438ed6bda42e3c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 20 Nov 2025 11:39:04 -0800 Subject: [PATCH 02/38] Add new HistoryComments Modules --- share-api/share-api.cabal | 3 +++ .../src/Share/Web/UCM/HistoryComments/API.hs | 8 ++++++++ .../src/Share/Web/UCM/HistoryComments/Impl.hs | 12 ++++++++++++ .../Share/Web/UCM/HistoryComments/Queries.hs | 17 +++++++++++++++++ 4 files changed, 40 insertions(+) create mode 100644 share-api/src/Share/Web/UCM/HistoryComments/API.hs create mode 100644 share-api/src/Share/Web/UCM/HistoryComments/Impl.hs create mode 100644 share-api/src/Share/Web/UCM/HistoryComments/Queries.hs diff --git a/share-api/share-api.cabal b/share-api/share-api.cabal index 07c04783..ccc63d8a 100644 --- a/share-api/share-api.cabal +++ b/share-api/share-api.cabal @@ -194,6 +194,9 @@ library Share.Web.Support.Impl Share.Web.Support.Types Share.Web.Types + Share.Web.UCM.HistoryComments.API + Share.Web.UCM.HistoryComments.Impl + Share.Web.UCM.HistoryComments.Queries Share.Web.UCM.Projects.Impl Share.Web.UCM.Sync.HashJWT Share.Web.UCM.Sync.Impl diff --git a/share-api/src/Share/Web/UCM/HistoryComments/API.hs b/share-api/src/Share/Web/UCM/HistoryComments/API.hs new file mode 100644 index 00000000..96be9d67 --- /dev/null +++ b/share-api/src/Share/Web/UCM/HistoryComments/API.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Share.Web.UCM.HistoryComments.API (API) where + +import Servant + +type API = NamedRoutes HistoryComments.Routes diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs new file mode 100644 index 00000000..4e739bb6 --- /dev/null +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -0,0 +1,12 @@ +module Share.Web.UCM.HistoryComments.Impl (server) where + +import Share.IDs +import Share.Web.App (WebAppServer) +import Share.Web.Share.Webhooks.API qualified as HistoryComments + +server :: Maybe UserId -> HistoryComments.Routes WebAppServer +server mayCaller = + HistoryComments.Routes + { downloadHistoryCommentsStream = downloadHistoryCommentsStreamImpl mayCaller, + uploadHistoryCommentsStream = uploadHistoryCommentsStreamImpl mayCaller + } diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs new file mode 100644 index 00000000..1ea7e276 --- /dev/null +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -0,0 +1,17 @@ +module Share.Web.UCM.HistoryComments.Queries () where + +import Data.Time (UTCTime) +import Share.Codebase.Types (CodebaseEnv (..)) +import Share.IDs +import Share.Postgres +import Share.Postgres.Cursors (PGCursor) +import Share.Postgres.Cursors qualified as PGCursor +import Share.Postgres.IDs +import Share.Prelude +import Share.Web.UCM.SyncV2.Types (IsCausalSpine (..), IsLibRoot (..)) +import U.Codebase.Sqlite.TempEntity (TempEntity) +import Unison.Hash32 (Hash32) +import Unison.SyncV2.Types (CBORBytes) + +fetchNewComments :: CodebaseEnv -> ProjectId -> CausalId -> UTCTime -> PGCursor HistoryCommentChunk +fetchNewComments codebase projectId causalId sinceTime = _ From b32c3c9966e5dec47360034c60fb6e5c42f84833 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 20 Nov 2025 13:24:42 -0800 Subject: [PATCH 03/38] Write fetch history comments queries --- .../Share/Web/UCM/HistoryComments/Queries.hs | 55 ++++++++++++++++--- ...24-04-18-00-00_causal_history_function.sql | 3 +- 2 files changed, 48 insertions(+), 10 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs index 1ea7e276..89504392 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -1,17 +1,54 @@ -module Share.Web.UCM.HistoryComments.Queries () where +{-# LANGUAGE RecordWildCards #-} + +module Share.Web.UCM.HistoryComments.Queries (fetchProjectBranchCommentsSince) where import Data.Time (UTCTime) -import Share.Codebase.Types (CodebaseEnv (..)) import Share.IDs -import Share.Postgres +import Share.Postgres qualified as PG import Share.Postgres.Cursors (PGCursor) -import Share.Postgres.Cursors qualified as PGCursor +import Share.Postgres.Cursors qualified as PG import Share.Postgres.IDs import Share.Prelude -import Share.Web.UCM.SyncV2.Types (IsCausalSpine (..), IsLibRoot (..)) -import U.Codebase.Sqlite.TempEntity (TempEntity) import Unison.Hash32 (Hash32) -import Unison.SyncV2.Types (CBORBytes) +import Unison.Server.HistoryComments.Types -fetchNewComments :: CodebaseEnv -> ProjectId -> CausalId -> UTCTime -> PGCursor HistoryCommentChunk -fetchNewComments codebase projectId causalId sinceTime = _ +fetchProjectBranchCommentsSince :: ProjectId -> CausalId -> UTCTime -> PG.Transaction e (PGCursor HistoryCommentChunk) +fetchProjectBranchCommentsSince projectId causalId sinceTime = do + PG.newRowCursor @(Bool, Maybe Text, Maybe Text, Maybe UTCTime, Maybe Bool, Maybe ByteString, Maybe Hash32, Maybe Text, Maybe UTCTime, Maybe ByteString, Maybe Hash32, Maybe Hash32) + "fetchProjectBranchCommentsSince" + [PG.sql| + WITH revisions(id, comment_id, subject, contents, created_at_ms, hidden, revision_hash, author_signature) AS ( + SELECT hcr.id, hc.id, hcr.subject, hcr.content, hcr.created_at_ms, hcr.is_hidden, hcr.revision_hash, hcr.author_signature + history_comment_revisions_project_discovery pd + JOIN history_comment_revisions hcr + ON pd.history_comment_revision_id = hcr.id + JOIN history_comments hc + ON hcr.history_comment_id = hc.id + WHERE + pd.project_id = #{projectId} + AND pd.discovered_at > #{sinceTime} + AND hc.causal_id IN (SELECT causal_id FROM causal_history(#{causalId})) + ) (SELECT true, NULL, (hc.author, hc.created_at_ms, key.thumbprint, causal.hash, hc.comment_hash) + FROM revisions rev + JOIN history_comments hc + ON revisions.comment_id = hc.id + JOIN causals causal + ON hc.causal_id = causal.id + JOIN personal_keys key + ON hc.author_key_id = key.id + ) + UNION ALL + -- Include ALL the base comments regardless of time, + -- the vast majority of the time we'll need them, it simplifies logic, + -- and the client can just ignore them if they already have them. + (SELECT DISTINCT ON (rev.comment_id) + false, (rev.subject, rev.content, rev.created_at, rev.is_hidden, rev.author_signature, rev.revision_hash), NULL + FROM revisions rev + ) + |] + <&> fmap \case + (True, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Just author, Just createdAt, Just authorThumbprint, Just causalHash, Just commentHash) -> + HistoryCommentChunk $ HistoryComment {..} + (False, Just subject, Just content, Just createdAt, Just isHidden, Just authorSignature, Just revisionHash, Nothing, Nothing, Nothing, Nothing, Nothing) -> + HistoryCommentRevisionChunk $ HistoryCommentRevision {..} + row -> error $ "fetchProjectBranchCommentsSince: Unexpected row format: " <> show row diff --git a/sql/2024-04-18-00-00_causal_history_function.sql b/sql/2024-04-18-00-00_causal_history_function.sql index 95df5ae6..adeb5eb8 100644 --- a/sql/2024-04-18-00-00_causal_history_function.sql +++ b/sql/2024-04-18-00-00_causal_history_function.sql @@ -1,5 +1,6 @@ --- Return all other causals in the history of a causal, including itself. +-- Return all other causals in the history (a.k.a. spine) of a causal, including itself. +-- This does not include any namespace child causals. CREATE FUNCTION causal_history(causal_id INTEGER) RETURNS TABLE (causal_id INTEGER) AS $$ From 2f926b4c9536ae93438a290f0d7d472de5d889ea Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 20 Nov 2025 13:24:42 -0800 Subject: [PATCH 04/38] Build against new unison From d28f2dbb56e17b5fa91a0f49436e12dca9969601 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 21 Nov 2025 11:11:34 -0800 Subject: [PATCH 05/38] Extract streaming utils --- share-api/share-api.cabal | 1 + .../src/Share/Utils/Servant/Streaming.hs | 58 +++++++++++++++++++ share-api/src/Share/Web/UCM/SyncV2/Impl.hs | 35 +---------- 3 files changed, 61 insertions(+), 33 deletions(-) create mode 100644 share-api/src/Share/Utils/Servant/Streaming.hs diff --git a/share-api/share-api.cabal b/share-api/share-api.cabal index ccc63d8a..4b2c5190 100644 --- a/share-api/share-api.cabal +++ b/share-api/share-api.cabal @@ -130,6 +130,7 @@ library Share.Utils.Servant.Client Share.Utils.Servant.PathInfo Share.Utils.Servant.RawRequest + Share.Utils.Servant.Streaming Share.Utils.Tags Share.Utils.Unison Share.Web.Admin.API diff --git a/share-api/src/Share/Utils/Servant/Streaming.hs b/share-api/src/Share/Utils/Servant/Streaming.hs new file mode 100644 index 00000000..6508fbf8 --- /dev/null +++ b/share-api/src/Share/Utils/Servant/Streaming.hs @@ -0,0 +1,58 @@ +module Share.Utils.Servant.Streaming + ( toConduit, + fromConduit, + sourceIOWithAsync, + queueToCBORStream, + queueToSourceIO, + ) +where + +-- Orphan instances for SourceIO + +import Codec.Serialise qualified as CBOR +import Conduit +import Control.Concurrent.STM.TBMQueue qualified as STM +import Data.ByteString.Builder qualified as Builder +import Ki.Unlifted qualified as Ki +import Servant +import Servant.Conduit (conduitToSourceIO) +import Servant.Types.SourceT +import Share.Prelude +import Unison.Util.Servant.CBOR +import UnliftIO.STM qualified as STM + +-- | Run the provided IO action in the background while streaming results. +-- +-- Servant doesn't provide any easier way to do bracketing like this, all the IO must be +-- inside the SourceIO somehow. +sourceIOWithAsync :: IO a -> SourceIO r -> SourceIO r +sourceIOWithAsync action (SourceT k) = + SourceT \k' -> + Ki.scoped \scope -> do + _ <- Ki.fork scope action + k k' + +toConduit :: (MonadIO m, MonadIO n) => SourceIO o -> m (ConduitT void o n ()) +toConduit sourceIO = fmap (transPipe liftIO) . liftIO $ fromSourceIO $ sourceIO + +fromConduit :: ConduitT void o IO () -> SourceIO o +fromConduit = conduitToSourceIO + +queueToCBORStream :: forall a f. (CBOR.Serialise a, Foldable f) => STM.TBMQueue (f a) -> ConduitT () (CBORStream a) IO () +queueToCBORStream q = do + let loop :: ConduitT () (CBORStream a) IO () + loop = do + liftIO (STM.atomically (STM.readTBMQueue q)) >>= \case + -- The queue is closed. + Nothing -> do + pure () + Just batches -> do + batches + & foldMap (CBOR.serialiseIncremental) + & (CBORStream . Builder.toLazyByteString) + & Conduit.yield + loop + loop + +queueToSourceIO :: forall a f. (CBOR.Serialise a, Foldable f) => STM.TBMQueue (f a) -> SourceIO (CBORStream a) +queueToSourceIO q = fromConduit (queueToCBORStream q) diff --git a/share-api/src/Share/Web/UCM/SyncV2/Impl.hs b/share-api/src/Share/Web/UCM/SyncV2/Impl.hs index c73bdbb1..d2b9c8a0 100644 --- a/share-api/src/Share/Web/UCM/SyncV2/Impl.hs +++ b/share-api/src/Share/Web/UCM/SyncV2/Impl.hs @@ -4,19 +4,15 @@ module Share.Web.UCM.SyncV2.Impl (server) where import Codec.Serialise qualified as CBOR -import Conduit qualified as C import Control.Concurrent.STM qualified as STM import Control.Concurrent.STM.TBMQueue qualified as STM import Control.Monad.Except (ExceptT (ExceptT), withExceptT) import Control.Monad.Trans.Except (runExceptT) -import Data.Binary.Builder qualified as Builder import Data.Set qualified as Set import Data.Text.Encoding qualified as Text import Data.Vector qualified as Vector -import Ki.Unlifted qualified as Ki import Servant import Servant.Conduit (ConduitToSourceIO (..)) -import Servant.Types.SourceT (SourceT (..)) import Servant.Types.SourceT qualified as SourceT import Share.Codebase qualified as Codebase import Share.IDs (ProjectBranchShortHand (..), ProjectReleaseShortHand (..), ProjectShortHand (..), UserHandle, UserId) @@ -30,6 +26,7 @@ import Share.Prelude import Share.Project (Project (..)) import Share.User (User (..)) import Share.Utils.Logging qualified as Logging +import Share.Utils.Servant.Streaming import Share.Utils.Unison (hash32ToCausalHash) import Share.Web.App import Share.Web.Authorization qualified as AuthZ @@ -123,24 +120,7 @@ causalDependenciesStreamImpl mayCallerUserId (SyncV2.CausalDependenciesRequest { in CausalHashDepC {causalHash, dependencyType} PG.transactionUnsafeIO $ STM.atomically $ STM.writeTBMQueue q depBatch PG.transactionUnsafeIO $ STM.atomically $ STM.closeTBMQueue q - pure $ sourceIOWithAsync streamResults $ conduitToSourceIO do - queueToStream q - -queueToStream :: forall a f. (CBOR.Serialise a, Foldable f) => STM.TBMQueue (f a) -> C.ConduitT () (SyncV2.CBORStream a) IO () -queueToStream q = do - let loop :: C.ConduitT () (SyncV2.CBORStream a) IO () - loop = do - liftIO (STM.atomically (STM.readTBMQueue q)) >>= \case - -- The queue is closed. - Nothing -> do - pure () - Just batches -> do - batches - & foldMap (CBOR.serialiseIncremental) - & (SyncV2.CBORStream . Builder.toLazyByteString) - & C.yield - loop - loop + pure $ sourceIOWithAsync streamResults $ queueToSourceIO q data CodebaseLoadingError = CodebaseLoadingErrorProjectNotFound ProjectShortHand @@ -178,14 +158,3 @@ codebaseForBranchRef branchRef = do authZToken <- lift AuthZ.checkDownloadFromProjectBranchCodebase `whenLeftM` \_err -> throwError (CodebaseLoadingErrorNoReadPermission branchRef) let codebaseLoc = Codebase.codebaseLocationForProjectBranchCodebase projectOwnerUserId contributorId pure $ Codebase.codebaseEnv authZToken codebaseLoc - --- | Run an IO action in the background while streaming the results. --- --- Servant doesn't provide any easier way to do bracketing like this, all the IO must be --- inside the SourceIO somehow. -sourceIOWithAsync :: IO a -> SourceIO r -> SourceIO r -sourceIOWithAsync action (SourceT k) = - SourceT \k' -> - Ki.scoped \scope -> do - _ <- Ki.fork scope action - k k' From a843e1c51d5dc3bd5a2b62cc8c49148705b6903c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 21 Nov 2025 11:11:34 -0800 Subject: [PATCH 06/38] Skeleton for HistoryComment endpoints --- .../src/Share/Web/UCM/HistoryComments/API.hs | 1 + .../src/Share/Web/UCM/HistoryComments/Impl.hs | 23 +++++++++++++++---- 2 files changed, 20 insertions(+), 4 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/API.hs b/share-api/src/Share/Web/UCM/HistoryComments/API.hs index 96be9d67..2875d432 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/API.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/API.hs @@ -4,5 +4,6 @@ module Share.Web.UCM.HistoryComments.API (API) where import Servant +import Unison.Server.HistoryComments.API qualified as HistoryComments type API = NamedRoutes HistoryComments.Routes diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 4e739bb6..169219e9 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -1,12 +1,27 @@ module Share.Web.UCM.HistoryComments.Impl (server) where +import Conduit (ConduitT) +import Servant import Share.IDs -import Share.Web.App (WebAppServer) -import Share.Web.Share.Webhooks.API qualified as HistoryComments +import Share.Utils.Servant.Streaming qualified as Streaming +import Share.Web.App (WebApp, WebAppServer) +import Share.Web.Errors (Unimplemented (Unimplemented), respondError) +import Unison.Server.HistoryComments.API qualified as HistoryComments +import Unison.Server.HistoryComments.Types (DownloadCommentsRequest (DownloadCommentsRequest), HistoryCommentChunk, UploadCommentsResponse) +import Unison.Util.Servant.CBOR server :: Maybe UserId -> HistoryComments.Routes WebAppServer server mayCaller = HistoryComments.Routes - { downloadHistoryCommentsStream = downloadHistoryCommentsStreamImpl mayCaller, - uploadHistoryCommentsStream = uploadHistoryCommentsStreamImpl mayCaller + { downloadHistoryComments = downloadHistoryCommentsStreamImpl mayCaller, + uploadHistoryComments = uploadHistoryCommentsStreamImpl mayCaller } + +downloadHistoryCommentsStreamImpl :: Maybe UserId -> DownloadCommentsRequest -> WebApp (SourceIO (CBORStream HistoryCommentChunk)) +downloadHistoryCommentsStreamImpl mayUserId (DownloadCommentsRequest {}) = do + respondError Unimplemented + +uploadHistoryCommentsStreamImpl :: Maybe UserId -> SourceIO (CBORStream HistoryCommentChunk) -> WebApp UploadCommentsResponse +uploadHistoryCommentsStreamImpl mayUserId inputStream = do + inputConduit :: ConduitT i HistoryCommentChunk IO () <- Streaming.toConduit inputStream + _ From 4fe9e1e550cb15bf1ad1f58a1f2473f27ec0be74 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 21 Nov 2025 12:26:14 -0800 Subject: [PATCH 07/38] Write most of the History Comment insert queries --- share-api/src/Share/Postgres/IDs.hs | 5 + .../Share/Web/UCM/HistoryComments/Queries.hs | 150 ++++++++++++++++-- 2 files changed, 146 insertions(+), 9 deletions(-) diff --git a/share-api/src/Share/Postgres/IDs.hs b/share-api/src/Share/Postgres/IDs.hs index 6f2d698b..c16da11f 100644 --- a/share-api/src/Share/Postgres/IDs.hs +++ b/share-api/src/Share/Postgres/IDs.hs @@ -23,6 +23,7 @@ module Share.Postgres.IDs NamespaceTermMappingId (..), NamespaceTypeMappingId (..), ComponentSummaryDigest (..), + PersonalKeyId (..), -- * Conversions hash32AsComponentHash_, @@ -104,6 +105,10 @@ newtype ComponentSummaryDigest = ComponentSummaryDigest {unComponentSummaryDiges deriving stock (Show, Eq, Ord) deriving (PG.EncodeValue, PG.DecodeValue) via ByteString +newtype PersonalKeyId = PersonalKeyId {unPersonalKeyId :: Int32} + deriving stock (Eq, Ord, Show) + deriving (PG.DecodeValue, PG.EncodeValue) via Int32 + toHash32 :: (Coercible h Hash) => h -> Hash32 toHash32 = Hash32.fromHash . coerce diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs index 89504392..1d5300dc 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -1,20 +1,28 @@ {-# LANGUAGE RecordWildCards #-} -module Share.Web.UCM.HistoryComments.Queries (fetchProjectBranchCommentsSince) where +module Share.Web.UCM.HistoryComments.Queries + ( fetchProjectBranchCommentsSince, + insertHistoryComments, + ) +where +import Control.Lens +import Data.Containers.ListUtils (nubOrd) import Data.Time (UTCTime) +import Data.Time.Clock.POSIX qualified as POSIX import Share.IDs import Share.Postgres qualified as PG import Share.Postgres.Cursors (PGCursor) import Share.Postgres.Cursors qualified as PG import Share.Postgres.IDs import Share.Prelude +import Share.Web.Authorization (AuthZReceipt) import Unison.Hash32 (Hash32) import Unison.Server.HistoryComments.Types -fetchProjectBranchCommentsSince :: ProjectId -> CausalId -> UTCTime -> PG.Transaction e (PGCursor HistoryCommentChunk) -fetchProjectBranchCommentsSince projectId causalId sinceTime = do - PG.newRowCursor @(Bool, Maybe Text, Maybe Text, Maybe UTCTime, Maybe Bool, Maybe ByteString, Maybe Hash32, Maybe Text, Maybe UTCTime, Maybe ByteString, Maybe Hash32, Maybe Hash32) +fetchProjectBranchCommentsSince :: AuthZReceipt -> ProjectId -> CausalId -> UTCTime -> PG.Transaction e (PGCursor HistoryCommentChunk) +fetchProjectBranchCommentsSince !_authZ projectId causalId sinceTime = do + PG.newRowCursor @(Bool, Maybe Text, Maybe Text, Maybe Int64, Maybe Bool, Maybe ByteString, Maybe Hash32, Maybe Text, Maybe Int64, Maybe ByteString, Maybe Hash32, Maybe Hash32) "fetchProjectBranchCommentsSince" [PG.sql| WITH revisions(id, comment_id, subject, contents, created_at_ms, hidden, revision_hash, author_signature) AS ( @@ -42,13 +50,137 @@ fetchProjectBranchCommentsSince projectId causalId sinceTime = do -- the vast majority of the time we'll need them, it simplifies logic, -- and the client can just ignore them if they already have them. (SELECT DISTINCT ON (rev.comment_id) - false, (rev.subject, rev.content, rev.created_at, rev.is_hidden, rev.author_signature, rev.revision_hash), NULL + false, (rev.subject, rev.content, rev.created_at_ms, rev.is_hidden, rev.author_signature, rev.revision_hash), NULL FROM revisions rev ) |] <&> fmap \case - (True, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Just author, Just createdAt, Just authorThumbprint, Just causalHash, Just commentHash) -> - HistoryCommentChunk $ HistoryComment {..} - (False, Just subject, Just content, Just createdAt, Just isHidden, Just authorSignature, Just revisionHash, Nothing, Nothing, Nothing, Nothing, Nothing) -> - HistoryCommentRevisionChunk $ HistoryCommentRevision {..} + (True, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Just author, Just createdAtMs, Just authorThumbprint, Just causalHash, Just commentHash) -> + let createdAt = millisToUTCTime createdAtMs + in HistoryCommentChunk $ HistoryComment {..} + (False, Just subject, Just content, Just createdAtMs, Just isHidden, Just authorSignature, Just revisionHash, Nothing, Nothing, Nothing, Nothing, Nothing) -> + let createdAt = millisToUTCTime createdAtMs + in HistoryCommentRevisionChunk $ HistoryCommentRevision {..} row -> error $ "fetchProjectBranchCommentsSince: Unexpected row format: " <> show row + +insertThumbprints :: (PG.QueryA m) => [Text] -> m () +insertThumbprints thumbprints = do + PG.execute_ + [PG.sql| + INSERT INTO personal_keys (thumbprint) + SELECT * FROM ^{PG.toTable $ nubOrd thumbprints} + ON CONFLICT (thumbprint) DO NOTHING + |] + +-- Convert milliseconds since epoch to UTCTime _exactly_. +-- UTCTime has picosecond precision so this is lossless. +millisToUTCTime :: Int64 -> UTCTime +millisToUTCTime ms = + toRational ms + & (/ (1_000 :: Rational)) + & fromRational + & POSIX.posixSecondsToUTCTime + +utcTimeToMillis :: UTCTime -> Int64 +utcTimeToMillis utcTime = + POSIX.utcTimeToPOSIXSeconds utcTime + & toRational + & (* (1_000 :: Rational)) + & round + +insertHistoryComments :: AuthZReceipt -> ProjectId -> [HistoryCommentChunk] -> PG.Transaction e () +insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do + let (comments, revisions) = + chunks & foldMap \case + HistoryCommentChunk comment -> ([comment], []) + HistoryCommentRevisionChunk revision -> ([], [revision]) + HistoryCommentErrorChunk err -> error $ "HistoryCommentErrorChunk: " <> show err -- TODO Handle this + insertThumbprints $ comments <&> \HistoryComment {authorThumbprint} -> authorThumbprint + insertHistoryComments comments + insertRevisions revisions + insertDiscoveryInfo revisions + where + insertHistoryComments :: [HistoryComment] -> PG.Pipeline e () + insertHistoryComments comments = do + let commentsTable = + comments <&> \HistoryComment {..} -> + ( author, + utcTimeToMillis createdAt, + authorThumbprint, + causalHash, + commentHash + ) + PG.execute_ + [PG.sql| + WITH new_comments(author, created_at_ms, author_thumbprint, causal_hash, comment_hash) AS ( + VALUES ^{PG.toTable commentsTable} + ) + INSERT INTO history_comments(causal_id, author, created_at_ms, comment_hash, author_key_id) + SELECT causal.id, nc.author, nc.created_at_ms, nc.comment_hash, pk.id + FROM new_comments nc + JOIN causal causal + ON causal.hash = nc.causal_hash + JOIN personal_keys pk + ON pk.thumbprint = nc.author_thumbprint + ON CONFLICT DO NOTHING + |] + + insertRevisions :: [HistoryCommentRevision] -> PG.Pipeline e () + insertRevisions revs = do + let revsTable = + revs <&> \HistoryCommentRevision {..} -> + ( subject, + content, + utcTimeToMillis createdAt, + isHidden, + authorSignature, + revisionHash, + commentHash + ) + PG.execute_ + [PG.sql| + WITH new_revisions(subject, content, created_at_ms, hidden, author_signature, revision_hash, comment_hash) AS ( + VALUES ^{PG.toTable revsTable} + ) + INSERT INTO history_comment_revisions(comment_id, subject, contents, created_at_ms, hidden, author_signature, revision_hash) + SELECT hc.id, nr.subject, nr.contents, nr.created_at_ms, nr.hidden, nr.author_signature, nr.revision_hash + FROM new_revisions nr + JOIN history_comments hc + ON hc.comment_hash = nr.comment_hash + ON CONFLICT DO NOTHING + |] + let revHashTable = revs <&> \HistoryCommentRevision {..} -> (revisionHash) + PG.execute_ + [PG.sql| + WITH new_discoveries(revision_hash) AS ( + VALUES ^{PG.singleColumnTable revHashTable} + ) + INSERT INTO history_comment_revisions_project_discovery(project_id, history_comment_revision_id) + SELECT #{projectId}, hcr.id + FROM new_discoveries nd + JOIN history_comments hcr + ON hcr.revision_hash = nd.revision_hash + ON CONFLICT DO NOTHING + |] + insertDiscoveryInfo :: [HistoryCommentRevision] -> PG.Pipeline e () + insertDiscoveryInfo revs = do + let discoveryTable = + revs <&> \HistoryCommentRevision {..} -> + ( projectId, + commentHash, + utcTimeToMillis createdAt + ) + PG.execute_ + [PG.sql| + WITH new_discoveries(project_id, history_comment_hash, discovered_at) AS ( + VALUES ^{PG.toTable discoveryTable} + ) + INSERT INTO history_comment_revisions_project_discovery(project_id, history_comment_revision_id, discovered_at) + SELECT #{projectId}, hcr.id, nd.discovered_at + FROM new_discoveries nd + JOIN history_comments hc + ON hc.comment_hash = nd.history_comment_hash + JOIN history_comment_revisions hcr + ON hcr.history_comment_id = hc.id + ON CONFLICT DO NOTHING + |] From 23637fb08241a0bcc861bffbf8a50ec7bad0d336 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 21 Nov 2025 12:26:14 -0800 Subject: [PATCH 08/38] Use new stream utilities --- share-api/src/Share/Web/UCM/SyncV2/Impl.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/share-api/src/Share/Web/UCM/SyncV2/Impl.hs b/share-api/src/Share/Web/UCM/SyncV2/Impl.hs index d2b9c8a0..161376c4 100644 --- a/share-api/src/Share/Web/UCM/SyncV2/Impl.hs +++ b/share-api/src/Share/Web/UCM/SyncV2/Impl.hs @@ -92,7 +92,7 @@ downloadEntitiesStreamImpl mayCallerUserId (SyncV2.DownloadEntitiesRequest {caus PG.transactionUnsafeIO $ STM.atomically $ STM.writeTBMQueue q entityChunkBatch PG.transactionUnsafeIO $ STM.atomically $ STM.closeTBMQueue q pure $ sourceIOWithAsync streamResults $ conduitToSourceIO do - queueToStream q + queueToCBORStream q where emitErr :: SyncV2.DownloadEntitiesError -> SourceIO (SyncV2.CBORStream SyncV2.DownloadEntitiesChunk) emitErr err = SourceT.source [SyncV2.CBORStream . CBOR.serialise $ ErrorC (ErrorChunk err)] From 0a0341f87cac106ae6be6e53792f4e4f7029ded7 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 25 Nov 2025 18:14:02 -0800 Subject: [PATCH 09/38] WIP --- .../src/Share/Utils/Servant/Streaming.hs | 5 + .../src/Share/Web/UCM/HistoryComments/Impl.hs | 6 +- .../Share/Web/UCM/HistoryComments/Queries.hs | 134 ++++++++++-------- 3 files changed, 81 insertions(+), 64 deletions(-) diff --git a/share-api/src/Share/Utils/Servant/Streaming.hs b/share-api/src/Share/Utils/Servant/Streaming.hs index 6508fbf8..e03e5071 100644 --- a/share-api/src/Share/Utils/Servant/Streaming.hs +++ b/share-api/src/Share/Utils/Servant/Streaming.hs @@ -1,5 +1,6 @@ module Share.Utils.Servant.Streaming ( toConduit, + cborStreamToConduit, fromConduit, sourceIOWithAsync, queueToCBORStream, @@ -12,6 +13,7 @@ where import Codec.Serialise qualified as CBOR import Conduit import Control.Concurrent.STM.TBMQueue qualified as STM +import Control.Monad.Except import Data.ByteString.Builder qualified as Builder import Ki.Unlifted qualified as Ki import Servant @@ -35,6 +37,9 @@ sourceIOWithAsync action (SourceT k) = toConduit :: (MonadIO m, MonadIO n) => SourceIO o -> m (ConduitT void o n ()) toConduit sourceIO = fmap (transPipe liftIO) . liftIO $ fromSourceIO $ sourceIO +cborStreamToConduit :: (MonadIO m, MonadIO n, CBOR.Serialise o) => SourceIO (CBORStream o) -> m (ConduitT void o (ExceptT CBORStreamError n) ()) +cborStreamToConduit sourceIO = toConduit sourceIO <&> \stream -> (stream .| unpackCBORBytesStream) + fromConduit :: ConduitT void o IO () -> SourceIO o fromConduit = conduitToSourceIO diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 169219e9..481eb45b 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -1,6 +1,7 @@ module Share.Web.UCM.HistoryComments.Impl (server) where import Conduit (ConduitT) +import Data.Void import Servant import Share.IDs import Share.Utils.Servant.Streaming qualified as Streaming @@ -19,9 +20,12 @@ server mayCaller = downloadHistoryCommentsStreamImpl :: Maybe UserId -> DownloadCommentsRequest -> WebApp (SourceIO (CBORStream HistoryCommentChunk)) downloadHistoryCommentsStreamImpl mayUserId (DownloadCommentsRequest {}) = do + _ <- error "AUTH CHECK HERE" respondError Unimplemented uploadHistoryCommentsStreamImpl :: Maybe UserId -> SourceIO (CBORStream HistoryCommentChunk) -> WebApp UploadCommentsResponse uploadHistoryCommentsStreamImpl mayUserId inputStream = do - inputConduit :: ConduitT i HistoryCommentChunk IO () <- Streaming.toConduit inputStream + _ <- error "AUTH CHECK HERE" + inputConduit :: ConduitT Void HistoryCommentChunk IO () <- Streaming.cborStreamToConduit inputStream + insertHistoryComments _ diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs index 1d5300dc..744067f4 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE RecordWildCards #-} module Share.Web.UCM.HistoryComments.Queries @@ -22,11 +23,11 @@ import Unison.Server.HistoryComments.Types fetchProjectBranchCommentsSince :: AuthZReceipt -> ProjectId -> CausalId -> UTCTime -> PG.Transaction e (PGCursor HistoryCommentChunk) fetchProjectBranchCommentsSince !_authZ projectId causalId sinceTime = do - PG.newRowCursor @(Bool, Maybe Text, Maybe Text, Maybe Int64, Maybe Bool, Maybe ByteString, Maybe Hash32, Maybe Text, Maybe Int64, Maybe ByteString, Maybe Hash32, Maybe Hash32) + PG.newRowCursor @(Bool, Maybe Text, Maybe Text, Maybe Int64, Maybe Bool, Maybe ByteString, Maybe Hash32, Maybe Hash32, Maybe Text, Maybe Int64, Maybe Text, Maybe Hash32, Maybe Hash32) "fetchProjectBranchCommentsSince" [PG.sql| - WITH revisions(id, comment_id, subject, contents, created_at_ms, hidden, revision_hash, author_signature) AS ( - SELECT hcr.id, hc.id, hcr.subject, hcr.content, hcr.created_at_ms, hcr.is_hidden, hcr.revision_hash, hcr.author_signature + WITH revisions(id, comment_id, subject, contents, created_at_ms, hidden, revision_hash, comment_hash, author_signature) AS ( + SELECT hcr.id, hc.id, hcr.subject, hcr.content, hcr.created_at_ms, hcr.is_hidden, hcr.revision_hash, hc.comment_hash, hcr.author_signature history_comment_revisions_project_discovery pd JOIN history_comment_revisions hcr ON pd.history_comment_revision_id = hcr.id @@ -36,7 +37,7 @@ fetchProjectBranchCommentsSince !_authZ projectId causalId sinceTime = do pd.project_id = #{projectId} AND pd.discovered_at > #{sinceTime} AND hc.causal_id IN (SELECT causal_id FROM causal_history(#{causalId})) - ) (SELECT true, NULL, (hc.author, hc.created_at_ms, key.thumbprint, causal.hash, hc.comment_hash) + ) (SELECT true, NULL, NULL, NULL, NULL, NULL, NULL, NULL, hc.author, hc.created_at_ms, key.thumbprint, causal.hash, hc.comment_hash FROM revisions rev JOIN history_comments hc ON revisions.comment_id = hc.id @@ -50,15 +51,15 @@ fetchProjectBranchCommentsSince !_authZ projectId causalId sinceTime = do -- the vast majority of the time we'll need them, it simplifies logic, -- and the client can just ignore them if they already have them. (SELECT DISTINCT ON (rev.comment_id) - false, (rev.subject, rev.content, rev.created_at_ms, rev.is_hidden, rev.author_signature, rev.revision_hash), NULL + false, rev.subject, rev.content, rev.created_at_ms, rev.is_hidden, rev.author_signature, rev.revision_hash, rev.comment_hash, NULL, NULL, NULL, NULL, NULL FROM revisions rev ) |] <&> fmap \case - (True, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Just author, Just createdAtMs, Just authorThumbprint, Just causalHash, Just commentHash) -> + (True, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Just author, Just createdAtMs, Just authorThumbprint, Just causalHash, Just commentHash) -> let createdAt = millisToUTCTime createdAtMs in HistoryCommentChunk $ HistoryComment {..} - (False, Just subject, Just content, Just createdAtMs, Just isHidden, Just authorSignature, Just revisionHash, Nothing, Nothing, Nothing, Nothing, Nothing) -> + (False, Just subject, Just content, Just createdAtMs, Just isHidden, Just authorSignature, Just revisionHash, Just commentHash, Nothing, Nothing, Nothing, Nothing, Nothing) -> let createdAt = millisToUTCTime createdAtMs in HistoryCommentRevisionChunk $ HistoryCommentRevision {..} row -> error $ "fetchProjectBranchCommentsSince: Unexpected row format: " <> show row @@ -68,7 +69,7 @@ insertThumbprints thumbprints = do PG.execute_ [PG.sql| INSERT INTO personal_keys (thumbprint) - SELECT * FROM ^{PG.toTable $ nubOrd thumbprints} + SELECT * FROM ^{PG.singleColumnTable $ nubOrd thumbprints} ON CONFLICT (thumbprint) DO NOTHING |] @@ -90,26 +91,19 @@ utcTimeToMillis utcTime = insertHistoryComments :: AuthZReceipt -> ProjectId -> [HistoryCommentChunk] -> PG.Transaction e () insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do - let (comments, revisions) = - chunks & foldMap \case - HistoryCommentChunk comment -> ([comment], []) - HistoryCommentRevisionChunk revision -> ([], [revision]) - HistoryCommentErrorChunk err -> error $ "HistoryCommentErrorChunk: " <> show err -- TODO Handle this - insertThumbprints $ comments <&> \HistoryComment {authorThumbprint} -> authorThumbprint + insertThumbprints $ (comments <&> \HistoryComment {authorThumbprint} -> authorThumbprint) insertHistoryComments comments insertRevisions revisions insertDiscoveryInfo revisions + pure () where + (comments, revisions) = + chunks & foldMap \case + HistoryCommentChunk comment -> ([comment], []) + HistoryCommentRevisionChunk revision -> ([], [revision]) + HistoryCommentErrorChunk err -> error $ "HistoryCommentErrorChunk: " <> show err -- TODO Handle this insertHistoryComments :: [HistoryComment] -> PG.Pipeline e () insertHistoryComments comments = do - let commentsTable = - comments <&> \HistoryComment {..} -> - ( author, - utcTimeToMillis createdAt, - authorThumbprint, - causalHash, - commentHash - ) PG.execute_ [PG.sql| WITH new_comments(author, created_at_ms, author_thumbprint, causal_hash, comment_hash) AS ( @@ -124,52 +118,59 @@ insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do ON pk.thumbprint = nc.author_thumbprint ON CONFLICT DO NOTHING |] + where + commentsTable = + comments <&> \HistoryComment {..} -> + ( author, + utcTimeToMillis createdAt, + authorThumbprint, + causalHash, + commentHash + ) insertRevisions :: [HistoryCommentRevision] -> PG.Pipeline e () insertRevisions revs = do - let revsTable = - revs <&> \HistoryCommentRevision {..} -> - ( subject, - content, - utcTimeToMillis createdAt, - isHidden, - authorSignature, - revisionHash, - commentHash - ) - PG.execute_ - [PG.sql| - WITH new_revisions(subject, content, created_at_ms, hidden, author_signature, revision_hash, comment_hash) AS ( - VALUES ^{PG.toTable revsTable} - ) - INSERT INTO history_comment_revisions(comment_id, subject, contents, created_at_ms, hidden, author_signature, revision_hash) - SELECT hc.id, nr.subject, nr.contents, nr.created_at_ms, nr.hidden, nr.author_signature, nr.revision_hash - FROM new_revisions nr - JOIN history_comments hc - ON hc.comment_hash = nr.comment_hash - ON CONFLICT DO NOTHING - |] - let revHashTable = revs <&> \HistoryCommentRevision {..} -> (revisionHash) - PG.execute_ - [PG.sql| - WITH new_discoveries(revision_hash) AS ( - VALUES ^{PG.singleColumnTable revHashTable} - ) - INSERT INTO history_comment_revisions_project_discovery(project_id, history_comment_revision_id) - SELECT #{projectId}, hcr.id - FROM new_discoveries nd - JOIN history_comments hcr - ON hcr.revision_hash = nd.revision_hash - ON CONFLICT DO NOTHING - |] + let doRevs = + PG.execute_ + [PG.sql| + WITH new_revisions(subject, content, created_at_ms, hidden, author_signature, revision_hash, comment_hash) AS ( + VALUES ^{PG.toTable revsTable} + ) + INSERT INTO history_comment_revisions(comment_id, subject, contents, created_at_ms, hidden, author_signature, revision_hash) + SELECT hc.id, nr.subject, nr.contents, nr.created_at_ms, nr.hidden, nr.author_signature, nr.revision_hash + FROM new_revisions nr + JOIN history_comments hc + ON hc.comment_hash = nr.comment_hash + ON CONFLICT DO NOTHING + |] + doDiscovery = + PG.execute_ + [PG.sql| + WITH new_discoveries(revision_hash) AS ( + VALUES ^{PG.singleColumnTable revHashTable} + ) + INSERT INTO history_comment_revisions_project_discovery(project_id, history_comment_revision_id) + SELECT #{projectId}, hcr.id + FROM new_discoveries nd + JOIN history_comments hcr + ON hcr.revision_hash = nd.revision_hash + ON CONFLICT DO NOTHING + |] + doRevs *> doDiscovery + where + revsTable = + revs <&> \HistoryCommentRevision {..} -> + ( subject, + content, + utcTimeToMillis createdAt, + isHidden, + authorSignature, + revisionHash, + commentHash + ) + revHashTable = revs <&> \HistoryCommentRevision {..} -> (revisionHash) insertDiscoveryInfo :: [HistoryCommentRevision] -> PG.Pipeline e () insertDiscoveryInfo revs = do - let discoveryTable = - revs <&> \HistoryCommentRevision {..} -> - ( projectId, - commentHash, - utcTimeToMillis createdAt - ) PG.execute_ [PG.sql| WITH new_discoveries(project_id, history_comment_hash, discovered_at) AS ( @@ -184,3 +185,10 @@ insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do ON hcr.history_comment_id = hc.id ON CONFLICT DO NOTHING |] + where + discoveryTable = + revs <&> \HistoryCommentRevision {..} -> + ( projectId, + commentHash, + utcTimeToMillis createdAt + ) From 42f929c9b44c5179dedf4aa391ae7f2c345a8c17 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 26 Nov 2025 12:35:12 -0800 Subject: [PATCH 10/38] WIP --- share-api/src/Share/Web/UCM/HistoryComments/Impl.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 481eb45b..418298d2 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -18,14 +18,19 @@ server mayCaller = uploadHistoryComments = uploadHistoryCommentsStreamImpl mayCaller } -downloadHistoryCommentsStreamImpl :: Maybe UserId -> DownloadCommentsRequest -> WebApp (SourceIO (CBORStream HistoryCommentChunk)) +wsMessageBufferSize :: Int +wsMessageBufferSize = 100 + +downloadHistoryCommentsStreamImpl :: Maybe UserId -> Connection -> WebApp () downloadHistoryCommentsStreamImpl mayUserId (DownloadCommentsRequest {}) = do _ <- error "AUTH CHECK HERE" respondError Unimplemented -uploadHistoryCommentsStreamImpl :: Maybe UserId -> SourceIO (CBORStream HistoryCommentChunk) -> WebApp UploadCommentsResponse -uploadHistoryCommentsStreamImpl mayUserId inputStream = do +uploadHistoryCommentsStreamImpl :: Maybe UserId -> BranchRef -> Connection -> WebApp () +uploadHistoryCommentsStreamImpl mayUserId branchRef conn = do _ <- error "AUTH CHECK HERE" + withQueues @HistoryCommentChunk @_ wsMessageBufferSize wsMessageBufferSize conn \Queues{receive, send, shutdown, connectionClosed} -> do + atomically receive inputConduit :: ConduitT Void HistoryCommentChunk IO () <- Streaming.cborStreamToConduit inputStream insertHistoryComments _ From 229b587d6539ec6cd131a11bca7e4a6ae6e97d7c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 26 Nov 2025 13:11:28 -0800 Subject: [PATCH 11/38] Integrate new Queuing primitives --- share-api/package.yaml | 1 + share-api/share-api.cabal | 2 + .../src/Share/Web/UCM/HistoryComments/Impl.hs | 39 ++++++++++++++++--- 3 files changed, 36 insertions(+), 6 deletions(-) diff --git a/share-api/package.yaml b/share-api/package.yaml index f1b5caf2..7fdc83c2 100644 --- a/share-api/package.yaml +++ b/share-api/package.yaml @@ -154,6 +154,7 @@ dependencies: - wai-extra - wai-middleware-prometheus - warp +- websockets - witch - witherable - x509 diff --git a/share-api/share-api.cabal b/share-api/share-api.cabal index 4b2c5190..95bd0074 100644 --- a/share-api/share-api.cabal +++ b/share-api/share-api.cabal @@ -360,6 +360,7 @@ library , wai-extra , wai-middleware-prometheus , warp + , websockets , witch , witherable , x509 @@ -517,6 +518,7 @@ executable share-api , wai-extra , wai-middleware-prometheus , warp + , websockets , witch , witherable , x509 diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 418298d2..a3fae6bb 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -2,6 +2,7 @@ module Share.Web.UCM.HistoryComments.Impl (server) where import Conduit (ConduitT) import Data.Void +import Network.WebSockets.Connection import Servant import Share.IDs import Share.Utils.Servant.Streaming qualified as Streaming @@ -10,6 +11,7 @@ import Share.Web.Errors (Unimplemented (Unimplemented), respondError) import Unison.Server.HistoryComments.API qualified as HistoryComments import Unison.Server.HistoryComments.Types (DownloadCommentsRequest (DownloadCommentsRequest), HistoryCommentChunk, UploadCommentsResponse) import Unison.Util.Servant.CBOR +import Unison.Util.Websockets server :: Maybe UserId -> HistoryComments.Routes WebAppServer server mayCaller = @@ -26,11 +28,36 @@ downloadHistoryCommentsStreamImpl mayUserId (DownloadCommentsRequest {}) = do _ <- error "AUTH CHECK HERE" respondError Unimplemented +-- Re-run the given STM action at most n times, collecting the results into a list. +-- If the action returns Nothing, stop early and return what has been collected so far, along with a Bool indicating whether the action was exhausted. +fetchChunk :: Int -> STM (Maybe a) -> STM ([a], Bool) +fetchChunk size action = do + let go 0 = pure [] + go n = do + optional action >>= \case + Nothing -> do + -- No more values available at the moment + pure ([], False) + Just Nothing -> do + -- Queue is closed + pure ([], True) + Just (Just val) -> do + (rest, exhausted) <- go (n - 1) + pure (val : rest, exhausted) + go size + uploadHistoryCommentsStreamImpl :: Maybe UserId -> BranchRef -> Connection -> WebApp () uploadHistoryCommentsStreamImpl mayUserId branchRef conn = do - _ <- error "AUTH CHECK HERE" - withQueues @HistoryCommentChunk @_ wsMessageBufferSize wsMessageBufferSize conn \Queues{receive, send, shutdown, connectionClosed} -> do - atomically receive - inputConduit :: ConduitT Void HistoryCommentChunk IO () <- Streaming.cborStreamToConduit inputStream - insertHistoryComments - _ + authZ <- error "AUTH CHECK HERE" + projectId <- error "Process Branch Ref" + withQueues @HistoryCommentChunk @_ wsMessageBufferSize wsMessageBufferSize conn \Queues {receive} -> do + errVar <- newEmptyMVar + let loop = do + chunk <- fetchChunk insertCommentBatchSize do + receive <&> fmap \case + HistoryCommentErrorChunk err -> Just (Left err) + chunk -> Just (Right chunk) + PG.runTransaction $ Q.insertHistoryComments authZ projectId chunk + loop + where + insertCommentBatchSize = 100 From 360bf0e8f173a04688e1ef5bf1ce824484ecbc02 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 26 Nov 2025 13:49:28 -0800 Subject: [PATCH 12/38] main insert loop done --- .../src/Share/Web/UCM/HistoryComments/Impl.hs | 39 ++++++++++++------- 1 file changed, 26 insertions(+), 13 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index a3fae6bb..d4fcceb7 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -1,17 +1,24 @@ module Share.Web.UCM.HistoryComments.Impl (server) where import Conduit (ConduitT) +import Data.Either (partitionEithers) import Data.Void import Network.WebSockets.Connection import Servant import Share.IDs +import Share.Postgres qualified as PG +import Share.Prelude import Share.Utils.Servant.Streaming qualified as Streaming import Share.Web.App (WebApp, WebAppServer) -import Share.Web.Errors (Unimplemented (Unimplemented), respondError) +import Share.Web.Errors (Unimplemented (Unimplemented), reportError, respondError) +import Share.Web.UCM.HistoryComments.Queries (insertHistoryComments) +import Share.Web.UCM.HistoryComments.Queries qualified as Q import Unison.Server.HistoryComments.API qualified as HistoryComments -import Unison.Server.HistoryComments.Types (DownloadCommentsRequest (DownloadCommentsRequest), HistoryCommentChunk, UploadCommentsResponse) +import Unison.Server.HistoryComments.Types (DownloadCommentsRequest (DownloadCommentsRequest), HistoryCommentChunk (..), UploadCommentsResponse) +import Unison.Server.Types import Unison.Util.Servant.CBOR import Unison.Util.Websockets +import UnliftIO server :: Maybe UserId -> HistoryComments.Routes WebAppServer server mayCaller = @@ -32,7 +39,7 @@ downloadHistoryCommentsStreamImpl mayUserId (DownloadCommentsRequest {}) = do -- If the action returns Nothing, stop early and return what has been collected so far, along with a Bool indicating whether the action was exhausted. fetchChunk :: Int -> STM (Maybe a) -> STM ([a], Bool) fetchChunk size action = do - let go 0 = pure [] + let go 0 = pure ([], False) go n = do optional action >>= \case Nothing -> do @@ -50,14 +57,20 @@ uploadHistoryCommentsStreamImpl :: Maybe UserId -> BranchRef -> Connection -> We uploadHistoryCommentsStreamImpl mayUserId branchRef conn = do authZ <- error "AUTH CHECK HERE" projectId <- error "Process Branch Ref" - withQueues @HistoryCommentChunk @_ wsMessageBufferSize wsMessageBufferSize conn \Queues {receive} -> do - errVar <- newEmptyMVar - let loop = do - chunk <- fetchChunk insertCommentBatchSize do + result <- withQueues @HistoryCommentChunk @_ wsMessageBufferSize wsMessageBufferSize conn \Queues {receive} -> do + let loop :: WebApp () + loop = do + (chunk, closed) <- atomically $ fetchChunk insertCommentBatchSize do receive <&> fmap \case - HistoryCommentErrorChunk err -> Just (Left err) - chunk -> Just (Right chunk) - PG.runTransaction $ Q.insertHistoryComments authZ projectId chunk - loop - where - insertCommentBatchSize = 100 + HistoryCommentErrorChunk err -> (Left err) + chunk -> (Right chunk) + let (errs, chunks) = partitionEithers chunk + for_ errs reportError + PG.runTransaction $ Q.insertHistoryComments authZ projectId chunks + when (not closed) loop + loop + case result of + Left err -> reportError err + Right () -> pure () + where + insertCommentBatchSize = 100 From fddf0f11fe3baaa4fe54ec7076ace082296c29b3 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 26 Nov 2025 14:11:14 -0800 Subject: [PATCH 13/38] Do a bunch of error handling --- share-api/src/Share/Web/Authentication.hs | 5 ++ .../src/Share/Web/UCM/HistoryComments/Impl.hs | 50 +++++++++++++------ 2 files changed, 40 insertions(+), 15 deletions(-) diff --git a/share-api/src/Share/Web/Authentication.hs b/share-api/src/Share/Web/Authentication.hs index dde86c50..f3d6373d 100644 --- a/share-api/src/Share/Web/Authentication.hs +++ b/share-api/src/Share/Web/Authentication.hs @@ -6,6 +6,7 @@ module Share.Web.Authentication ( cookieSessionTTL, requireAuthenticatedUser, + requireAuthenticatedUser', UnauthenticatedError (..), pattern MaybeAuthedUserID, pattern AuthenticatedUser, @@ -39,3 +40,7 @@ instance ToServerError UnauthenticatedError where requireAuthenticatedUser :: Maybe Session -> WebApp UserId requireAuthenticatedUser (AuthenticatedUser uid) = pure uid requireAuthenticatedUser _ = Errors.respondError UnauthenticatedError + +requireAuthenticatedUser' :: Maybe UserId -> WebApp UserId +requireAuthenticatedUser' (Just uid) = pure uid +requireAuthenticatedUser' _ = Errors.respondError UnauthenticatedError diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index d4fcceb7..7cdf6eb0 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -1,22 +1,23 @@ module Share.Web.UCM.HistoryComments.Impl (server) where -import Conduit (ConduitT) +import Control.Monad.Except +import Control.Monad.Trans.Maybe import Data.Either (partitionEithers) -import Data.Void import Network.WebSockets.Connection -import Servant import Share.IDs +import Share.IDs qualified as IDs import Share.Postgres qualified as PG +import Share.Postgres.Queries qualified as PGQ +import Share.Postgres.Users.Queries qualified as UserQ import Share.Prelude -import Share.Utils.Servant.Streaming qualified as Streaming import Share.Web.App (WebApp, WebAppServer) +import Share.Web.Authentication qualified as AuthN +import Share.Web.Authorization qualified as AuthZ import Share.Web.Errors (Unimplemented (Unimplemented), reportError, respondError) -import Share.Web.UCM.HistoryComments.Queries (insertHistoryComments) import Share.Web.UCM.HistoryComments.Queries qualified as Q import Unison.Server.HistoryComments.API qualified as HistoryComments -import Unison.Server.HistoryComments.Types (DownloadCommentsRequest (DownloadCommentsRequest), HistoryCommentChunk (..), UploadCommentsResponse) +import Unison.Server.HistoryComments.Types (DownloadCommentsRequest (DownloadCommentsRequest), HistoryCommentChunk (..), UploadCommentsResponse (..)) import Unison.Server.Types -import Unison.Util.Servant.CBOR import Unison.Util.Websockets import UnliftIO @@ -54,23 +55,42 @@ fetchChunk size action = do go size uploadHistoryCommentsStreamImpl :: Maybe UserId -> BranchRef -> Connection -> WebApp () -uploadHistoryCommentsStreamImpl mayUserId branchRef conn = do - authZ <- error "AUTH CHECK HERE" - projectId <- error "Process Branch Ref" - result <- withQueues @HistoryCommentChunk @_ wsMessageBufferSize wsMessageBufferSize conn \Queues {receive} -> do - let loop :: WebApp () +uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = do + callerUserId <- AuthN.requireAuthenticatedUser' mayCallerUserId + result <- withQueues @UploadCommentsResponse @HistoryCommentChunk wsMessageBufferSize wsMessageBufferSize conn \q@(Queues {receive}) -> runExceptT $ do + projectBranchSH@ProjectBranchShortHand {userHandle, projectSlug, contributorHandle} <- case IDs.fromText @ProjectBranchShortHand branchRef of + Left err -> handleErrInQueue q (UploadCommentsGenericFailure $ IDs.toText err) + Right pbsh -> pure pbsh + let projectSH = ProjectShortHand {userHandle, projectSlug} + mayInfo <- runMaybeT $ mapMaybeT PG.runTransaction $ do + project <- MaybeT $ PGQ.projectByShortHand projectSH + branch <- MaybeT $ PGQ.branchByProjectBranchShortHand projectBranchSH + contributorUser <- MaybeT $ for contributorHandle UserQ.userByHandle + pure (project, branch, contributorUser) + (project, branch, contributorUser) <- maybe (handleErrInQueue q $ UploadCommentsProjectBranchNotFound br) pure $ mayInfo + authZ <- + lift (AuthZ.checkUploadToProjectBranchCodebase callerUserId project.projectId contributorUser.user_id) >>= \case + Left _authErr -> handleErrInQueue q (UploadCommentsNotAuthorized br) + Right authZ -> pure authZ + projectId <- error "Process Branch Ref" + let loop :: ExceptT UploadCommentsResponse WebApp () loop = do (chunk, closed) <- atomically $ fetchChunk insertCommentBatchSize do receive <&> fmap \case - HistoryCommentErrorChunk err -> (Left err) + HistoryCommentErrorChunk err -> (Left $ UploadCommentsGenericFailure err) chunk -> (Right chunk) let (errs, chunks) = partitionEithers chunk - for_ errs reportError PG.runTransaction $ Q.insertHistoryComments authZ projectId chunks + for errs $ \err -> handleErrInQueue q err when (not closed) loop loop case result of Left err -> reportError err - Right () -> pure () + Right (Left err) -> reportError err + Right (Right ()) -> pure () where insertCommentBatchSize = 100 + handleErrInQueue :: forall o x. Queues UploadCommentsResponse o -> UploadCommentsResponse -> ExceptT UploadCommentsResponse WebApp x + handleErrInQueue Queues {send} e = do + _ <- atomically $ send e + throwError e From 081fab11f43af9692ef368839a16f50af7b6ffe9 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 26 Nov 2025 14:43:43 -0800 Subject: [PATCH 14/38] Add history comments to api --- share-api/src/Share/Web/API.hs | 2 ++ share-api/src/Share/Web/UCM/HistoryComments/Impl.hs | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/share-api/src/Share/Web/API.hs b/share-api/src/Share/Web/API.hs index 2c7816b3..303f7b6b 100644 --- a/share-api/src/Share/Web/API.hs +++ b/share-api/src/Share/Web/API.hs @@ -18,6 +18,7 @@ import Share.Web.Share.Webhooks.API qualified as Webhooks import Share.Web.Support.API qualified as Support import Share.Web.Types import Share.Web.UCM.SyncV2.API qualified as SyncV2 +import Unison.Server.HistoryComments.API qualified as Unison.HistoryComments import Unison.Share.API.Projects qualified as UCMProjects import Unison.Sync.API qualified as Unison.Sync @@ -53,6 +54,7 @@ type API = -- This path is deprecated, but is still in use by existing clients. :<|> ("sync" :> MaybeAuthenticatedSession :> Unison.Sync.API) :<|> ("ucm" :> "v1" :> "sync" :> MaybeAuthenticatedSession :> Unison.Sync.API) + :<|> ("ucm" :> "v1" :> "history-comments" :> MaybeAuthenticatedSession :> Unison.HistoryComments.API) :<|> ("ucm" :> "v1" :> "projects" :> MaybeAuthenticatedSession :> UCMProjects.ProjectsAPI) :<|> ("ucm" :> "v2" :> "sync" :> MaybeAuthenticatedUserId :> SyncV2.API) :<|> ("admin" :> Admin.API) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 7cdf6eb0..2b4ce4cd 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -67,7 +67,7 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = branch <- MaybeT $ PGQ.branchByProjectBranchShortHand projectBranchSH contributorUser <- MaybeT $ for contributorHandle UserQ.userByHandle pure (project, branch, contributorUser) - (project, branch, contributorUser) <- maybe (handleErrInQueue q $ UploadCommentsProjectBranchNotFound br) pure $ mayInfo + (project, _branch, contributorUser) <- maybe (handleErrInQueue q $ UploadCommentsProjectBranchNotFound br) pure $ mayInfo authZ <- lift (AuthZ.checkUploadToProjectBranchCodebase callerUserId project.projectId contributorUser.user_id) >>= \case Left _authErr -> handleErrInQueue q (UploadCommentsNotAuthorized br) From 9c97a0163dc8cca72edb6da899674122a2368ebc Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 1 Dec 2025 16:57:47 -0800 Subject: [PATCH 15/38] Wire up UCM websockets --- share-api/src/Share/Prelude/Orphans.hs | 4 +++ share-api/src/Share/Utils/Logging.hs | 18 +++++++++++++ share-api/src/Share/Web/Errors.hs | 23 +++++++++++++++++ .../src/Share/Web/UCM/HistoryComments/Impl.hs | 25 +++++++++++-------- 4 files changed, 60 insertions(+), 10 deletions(-) diff --git a/share-api/src/Share/Prelude/Orphans.hs b/share-api/src/Share/Prelude/Orphans.hs index 055834ca..fa8ba593 100644 --- a/share-api/src/Share/Prelude/Orphans.hs +++ b/share-api/src/Share/Prelude/Orphans.hs @@ -6,6 +6,7 @@ module Share.Prelude.Orphans () where import Control.Comonad.Cofree (Cofree (..)) +import Control.Monad.Except import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT) import Data.Align (Semialign (..)) @@ -47,3 +48,6 @@ instance From ShortHash Text where instance (MonadTracer m) => MonadTracer (MaybeT m) where getTracer = lift getTracer + +instance (MonadTracer m) => MonadTracer (ExceptT e m) where + getTracer = lift getTracer diff --git a/share-api/src/Share/Utils/Logging.hs b/share-api/src/Share/Utils/Logging.hs index 0bcabc2d..e13d0770 100644 --- a/share-api/src/Share/Utils/Logging.hs +++ b/share-api/src/Share/Utils/Logging.hs @@ -45,6 +45,7 @@ import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Text.IO qualified as Text import GHC.Stack (CallStack, callStack, prettyCallStack) +import Network.WebSockets qualified as WS import Servant.Client qualified as Servant import Share.Env.Types qualified as Env import Share.OAuth.Errors (OAuth2Error) @@ -56,6 +57,8 @@ import Share.Utils.Logging.Types as X import Share.Utils.Tags (MonadTags) import System.Log.FastLogger qualified as FL import Unison.Server.Backend qualified as Backend +import Unison.Server.HistoryComments.Types (UploadCommentsResponse (..)) +import Unison.Server.Types (BranchRef (..)) import Unison.Sync.Types qualified as Sync import Unison.Util.Monoid (intercalateMap) import Unison.Util.Monoid qualified as Monoid @@ -267,3 +270,18 @@ instance Loggable Sync.UploadEntitiesError where Sync.UploadEntitiesError'UserNotFound userHandle -> textLog ("User not found: " <> userHandle) & withSeverity UserFault + +instance Loggable UploadCommentsResponse where + toLog = \case + UploadCommentsProjectBranchNotFound (BranchRef branchRef) -> + textLog ("Project branch not found: " <> branchRef) + & withSeverity UserFault + UploadCommentsNotAuthorized (BranchRef branchRef) -> + textLog ("Not authorized to upload comments to branch: " <> branchRef) + & withSeverity UserFault + UploadCommentsGenericFailure errMsg -> + textLog ("Upload comments generic failure: " <> errMsg) + & withSeverity Error + +instance Loggable WS.ConnectionException where + toLog = withSeverity Error . showLog diff --git a/share-api/src/Share/Web/Errors.hs b/share-api/src/Share/Web/Errors.hs index 55591eda..9d5594f4 100644 --- a/share-api/src/Share/Web/Errors.hs +++ b/share-api/src/Share/Web/Errors.hs @@ -53,6 +53,7 @@ import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import GHC.Stack qualified as GHC import GHC.TypeLits qualified as TL +import Network.WebSockets qualified as WS import Servant import Servant.Client import Share.Env.Types qualified as Env @@ -67,6 +68,8 @@ import Share.Utils.URI (URIParam (..), addQueryParam) import Share.Web.App import Unison.Server.Backend qualified as Backend import Unison.Server.Errors qualified as Backend +import Unison.Server.HistoryComments.Types (UploadCommentsResponse (..)) +import Unison.Server.Types (BranchRef (..)) import Unison.Sync.Types qualified as Sync import UnliftIO qualified @@ -423,3 +426,23 @@ instance ToServerError Sync.UploadEntitiesError where Sync.UploadEntitiesError'NoWritePermission _ -> ("no-write-permission", err403 {errBody = "No Write Permission"}) Sync.UploadEntitiesError'ProjectNotFound _ -> ("project-not-found", err404 {errBody = "Project Not Found"}) Sync.UploadEntitiesError'UserNotFound _ -> ("user-not-found", err404 {errBody = "User Not Found"}) + +instance ToServerError UploadCommentsResponse where + toServerError = \case + UploadCommentsProjectBranchNotFound (BranchRef branchRef) -> + (ErrorID "upload-comments:project-branch-not-found", err404 {errBody = BL.fromStrict $ Text.encodeUtf8 $ "Project branch not found: " <> branchRef}) + UploadCommentsNotAuthorized (BranchRef branchRef) -> + (ErrorID "upload-comments:not-authorized", err403 {errBody = BL.fromStrict $ Text.encodeUtf8 $ "Not authorized to upload comments to branch: " <> branchRef}) + UploadCommentsGenericFailure errMsg -> + (ErrorID "upload-comments:generic-failure", err500 {errBody = BL.fromStrict $ Text.encodeUtf8 $ "Upload comments failure: " <> errMsg}) + +instance ToServerError WS.ConnectionException where + toServerError = \case + WS.CloseRequest _ _ -> + (ErrorID "websocket:close-request", err400 {errBody = "WebSocket closed by client"}) + WS.ParseException msg -> + (ErrorID "websocket:parse-exception", err400 {errBody = BL.fromStrict $ Text.encodeUtf8 $ "Invalid message: parse exception: " <> Text.pack msg}) + WS.UnicodeException msg -> + (ErrorID "websocket:unicode-exception", err400 {errBody = BL.fromStrict $ Text.encodeUtf8 $ "Unicode decoding exception: " <> Text.pack msg}) + WS.ConnectionClosed -> + (ErrorID "websocket:connection-closed", err400 {errBody = "WebSocket connection closed"}) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 2b4ce4cd..ba853209 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -10,13 +10,15 @@ import Share.Postgres qualified as PG import Share.Postgres.Queries qualified as PGQ import Share.Postgres.Users.Queries qualified as UserQ import Share.Prelude +import Share.Project +import Share.User import Share.Web.App (WebApp, WebAppServer) import Share.Web.Authentication qualified as AuthN import Share.Web.Authorization qualified as AuthZ import Share.Web.Errors (Unimplemented (Unimplemented), reportError, respondError) import Share.Web.UCM.HistoryComments.Queries qualified as Q import Unison.Server.HistoryComments.API qualified as HistoryComments -import Unison.Server.HistoryComments.Types (DownloadCommentsRequest (DownloadCommentsRequest), HistoryCommentChunk (..), UploadCommentsResponse (..)) +import Unison.Server.HistoryComments.Types (HistoryCommentChunk (..), UploadCommentsResponse (..)) import Unison.Server.Types import Unison.Util.Websockets import UnliftIO @@ -32,7 +34,7 @@ wsMessageBufferSize :: Int wsMessageBufferSize = 100 downloadHistoryCommentsStreamImpl :: Maybe UserId -> Connection -> WebApp () -downloadHistoryCommentsStreamImpl mayUserId (DownloadCommentsRequest {}) = do +downloadHistoryCommentsStreamImpl _mayUserId _conn = do _ <- error "AUTH CHECK HERE" respondError Unimplemented @@ -57,19 +59,19 @@ fetchChunk size action = do uploadHistoryCommentsStreamImpl :: Maybe UserId -> BranchRef -> Connection -> WebApp () uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = do callerUserId <- AuthN.requireAuthenticatedUser' mayCallerUserId - result <- withQueues @UploadCommentsResponse @HistoryCommentChunk wsMessageBufferSize wsMessageBufferSize conn \q@(Queues {receive}) -> runExceptT $ do + result <- withQueues @(MsgOrError Void UploadCommentsResponse) @(MsgOrError Void HistoryCommentChunk) wsMessageBufferSize wsMessageBufferSize conn \q@(Queues {receive}) -> runExceptT $ do projectBranchSH@ProjectBranchShortHand {userHandle, projectSlug, contributorHandle} <- case IDs.fromText @ProjectBranchShortHand branchRef of Left err -> handleErrInQueue q (UploadCommentsGenericFailure $ IDs.toText err) Right pbsh -> pure pbsh let projectSH = ProjectShortHand {userHandle, projectSlug} - mayInfo <- runMaybeT $ mapMaybeT PG.runTransaction $ do + mayInfo <- lift . runMaybeT $ mapMaybeT PG.runTransaction $ do project <- MaybeT $ PGQ.projectByShortHand projectSH branch <- MaybeT $ PGQ.branchByProjectBranchShortHand projectBranchSH contributorUser <- MaybeT $ for contributorHandle UserQ.userByHandle pure (project, branch, contributorUser) (project, _branch, contributorUser) <- maybe (handleErrInQueue q $ UploadCommentsProjectBranchNotFound br) pure $ mayInfo authZ <- - lift (AuthZ.checkUploadToProjectBranchCodebase callerUserId project.projectId contributorUser.user_id) >>= \case + lift (AuthZ.checkUploadToProjectBranchCodebase callerUserId project.projectId (user_id <$> contributorUser)) >>= \case Left _authErr -> handleErrInQueue q (UploadCommentsNotAuthorized br) Right authZ -> pure authZ projectId <- error "Process Branch Ref" @@ -77,10 +79,13 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = loop = do (chunk, closed) <- atomically $ fetchChunk insertCommentBatchSize do receive <&> fmap \case - HistoryCommentErrorChunk err -> (Left $ UploadCommentsGenericFailure err) - chunk -> (Right chunk) + Msg (HistoryCommentErrorChunk err) -> (Left $ UploadCommentsGenericFailure err) + Msg chunk -> (Right chunk) + DeserialiseFailure msg -> (Left $ UploadCommentsGenericFailure msg) + UserErr err -> absurd err + let (errs, chunks) = partitionEithers chunk - PG.runTransaction $ Q.insertHistoryComments authZ projectId chunks + lift $ PG.runTransaction $ Q.insertHistoryComments authZ projectId chunks for errs $ \err -> handleErrInQueue q err when (not closed) loop loop @@ -90,7 +95,7 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = Right (Right ()) -> pure () where insertCommentBatchSize = 100 - handleErrInQueue :: forall o x. Queues UploadCommentsResponse o -> UploadCommentsResponse -> ExceptT UploadCommentsResponse WebApp x + handleErrInQueue :: forall o x e. Queues (MsgOrError e UploadCommentsResponse) o -> UploadCommentsResponse -> ExceptT UploadCommentsResponse WebApp x handleErrInQueue Queues {send} e = do - _ <- atomically $ send e + _ <- atomically $ send $ Msg e throwError e From 36af719d38cb1ac9ef559ddd9001bdd37b445b38 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 16 Dec 2025 14:02:51 -0800 Subject: [PATCH 16/38] Wire in API --- share-api/src/Share/Web/API.hs | 2 +- share-api/src/Share/Web/Impl.hs | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/share-api/src/Share/Web/API.hs b/share-api/src/Share/Web/API.hs index 303f7b6b..ab374607 100644 --- a/share-api/src/Share/Web/API.hs +++ b/share-api/src/Share/Web/API.hs @@ -54,7 +54,7 @@ type API = -- This path is deprecated, but is still in use by existing clients. :<|> ("sync" :> MaybeAuthenticatedSession :> Unison.Sync.API) :<|> ("ucm" :> "v1" :> "sync" :> MaybeAuthenticatedSession :> Unison.Sync.API) - :<|> ("ucm" :> "v1" :> "history-comments" :> MaybeAuthenticatedSession :> Unison.HistoryComments.API) + :<|> ("ucm" :> "v1" :> "history-comments" :> MaybeAuthenticatedUserId :> Unison.HistoryComments.API) :<|> ("ucm" :> "v1" :> "projects" :> MaybeAuthenticatedSession :> UCMProjects.ProjectsAPI) :<|> ("ucm" :> "v2" :> "sync" :> MaybeAuthenticatedUserId :> SyncV2.API) :<|> ("admin" :> Admin.API) diff --git a/share-api/src/Share/Web/Impl.hs b/share-api/src/Share/Web/Impl.hs index 13d5cad4..4c789722 100644 --- a/share-api/src/Share/Web/Impl.hs +++ b/share-api/src/Share/Web/Impl.hs @@ -27,6 +27,7 @@ import Share.Web.Share.Projects.Impl qualified as Projects import Share.Web.Share.Webhooks.Impl qualified as Webhooks import Share.Web.Support.Impl qualified as Support import Share.Web.Types +import Share.Web.UCM.HistoryComments.Impl qualified as HistoryComments import Share.Web.UCM.Projects.Impl qualified as UCMProjects import Share.Web.UCM.Sync.Impl qualified as Sync import Share.Web.UCM.SyncV2.Impl qualified as SyncV2 @@ -89,6 +90,7 @@ server = :<|> healthEndpoint :<|> Sync.server -- Deprecated path :<|> Sync.server + :<|> HistoryComments.server :<|> UCMProjects.server :<|> SyncV2.server :<|> Admin.server From f534112a8863b6c283a02de14f1ebad70d8ead6e Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 16 Dec 2025 14:41:57 -0800 Subject: [PATCH 17/38] Fix up thumbprint syncing --- share-api/src/Share/Web/UCM/HistoryComments/Impl.hs | 10 +++++++--- .../src/Share/Web/UCM/HistoryComments/Queries.hs | 11 +++++++---- 2 files changed, 14 insertions(+), 7 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index ba853209..ab2a6ce0 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -17,6 +17,7 @@ import Share.Web.Authentication qualified as AuthN import Share.Web.Authorization qualified as AuthZ import Share.Web.Errors (Unimplemented (Unimplemented), reportError, respondError) import Share.Web.UCM.HistoryComments.Queries qualified as Q +import Unison.Debug qualified as Debug import Unison.Server.HistoryComments.API qualified as HistoryComments import Unison.Server.HistoryComments.Types (HistoryCommentChunk (..), UploadCommentsResponse (..)) import Unison.Server.Types @@ -58,6 +59,7 @@ fetchChunk size action = do uploadHistoryCommentsStreamImpl :: Maybe UserId -> BranchRef -> Connection -> WebApp () uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = do + Debug.debugM Debug.Temp "uploadHistoryCommentsStreamImpl called with branchRef: " (IDs.toText branchRef, mayCallerUserId) callerUserId <- AuthN.requireAuthenticatedUser' mayCallerUserId result <- withQueues @(MsgOrError Void UploadCommentsResponse) @(MsgOrError Void HistoryCommentChunk) wsMessageBufferSize wsMessageBufferSize conn \q@(Queues {receive}) -> runExceptT $ do projectBranchSH@ProjectBranchShortHand {userHandle, projectSlug, contributorHandle} <- case IDs.fromText @ProjectBranchShortHand branchRef of @@ -66,15 +68,17 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = let projectSH = ProjectShortHand {userHandle, projectSlug} mayInfo <- lift . runMaybeT $ mapMaybeT PG.runTransaction $ do project <- MaybeT $ PGQ.projectByShortHand projectSH + Debug.debugM Debug.Temp "FOUND PROJECT" (project) branch <- MaybeT $ PGQ.branchByProjectBranchShortHand projectBranchSH - contributorUser <- MaybeT $ for contributorHandle UserQ.userByHandle + Debug.debugM Debug.Temp "FOUND BRANCH" (branch) + contributorUser <- for contributorHandle (MaybeT . UserQ.userByHandle) + Debug.debugM Debug.Temp "FOUND Contributor" (contributorUser) pure (project, branch, contributorUser) (project, _branch, contributorUser) <- maybe (handleErrInQueue q $ UploadCommentsProjectBranchNotFound br) pure $ mayInfo authZ <- lift (AuthZ.checkUploadToProjectBranchCodebase callerUserId project.projectId (user_id <$> contributorUser)) >>= \case Left _authErr -> handleErrInQueue q (UploadCommentsNotAuthorized br) Right authZ -> pure authZ - projectId <- error "Process Branch Ref" let loop :: ExceptT UploadCommentsResponse WebApp () loop = do (chunk, closed) <- atomically $ fetchChunk insertCommentBatchSize do @@ -85,7 +89,7 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = UserErr err -> absurd err let (errs, chunks) = partitionEithers chunk - lift $ PG.runTransaction $ Q.insertHistoryComments authZ projectId chunks + lift $ PG.runTransaction $ Q.insertHistoryComments authZ project.projectId chunks for errs $ \err -> handleErrInQueue q err when (not closed) loop loop diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs index 744067f4..9c8af16e 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -8,7 +8,9 @@ module Share.Web.UCM.HistoryComments.Queries where import Control.Lens -import Data.Containers.ListUtils (nubOrd) +import Data.Set qualified as Set +import Data.Set.NonEmpty (NESet) +import Data.Set.NonEmpty qualified as NESet import Data.Time (UTCTime) import Data.Time.Clock.POSIX qualified as POSIX import Share.IDs @@ -64,12 +66,12 @@ fetchProjectBranchCommentsSince !_authZ projectId causalId sinceTime = do in HistoryCommentRevisionChunk $ HistoryCommentRevision {..} row -> error $ "fetchProjectBranchCommentsSince: Unexpected row format: " <> show row -insertThumbprints :: (PG.QueryA m) => [Text] -> m () +insertThumbprints :: (PG.QueryA m) => NESet Text -> m () insertThumbprints thumbprints = do PG.execute_ [PG.sql| INSERT INTO personal_keys (thumbprint) - SELECT * FROM ^{PG.singleColumnTable $ nubOrd thumbprints} + SELECT * FROM ^{PG.singleColumnTable $ toList thumbprints} ON CONFLICT (thumbprint) DO NOTHING |] @@ -91,7 +93,8 @@ utcTimeToMillis utcTime = insertHistoryComments :: AuthZReceipt -> ProjectId -> [HistoryCommentChunk] -> PG.Transaction e () insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do - insertThumbprints $ (comments <&> \HistoryComment {authorThumbprint} -> authorThumbprint) + let thumbprints = NESet.nonEmptySet $ Set.fromList (comments <&> \HistoryComment {authorThumbprint} -> authorThumbprint) + for thumbprints insertThumbprints insertHistoryComments comments insertRevisions revisions insertDiscoveryInfo revisions From a48ca159754798b59668aa08309075317b554420 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 16 Dec 2025 15:51:27 -0800 Subject: [PATCH 18/38] Make history comment inserts conditional --- share-api/src/Share/Postgres.hs | 2 +- share-api/src/Share/Web/UCM/HistoryComments/Queries.hs | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/share-api/src/Share/Postgres.hs b/share-api/src/Share/Postgres.hs index b215028a..fcc36abb 100644 --- a/share-api/src/Share/Postgres.hs +++ b/share-api/src/Share/Postgres.hs @@ -685,7 +685,7 @@ cachedFor = cachedForOf traversed -- ) SELECT * FROM something JOIN users on something.user_id = users.id -- |] -- @@ -whenNonEmpty :: forall m f a x. (Monad m, Foldable f, Monoid a) => f x -> m a -> m a +whenNonEmpty :: forall m f a x. (Foldable f, Monoid a, Applicative m) => f x -> m a -> m a whenNonEmpty f m = if null f then pure mempty else m timeTransaction :: (QueryM m) => String -> m a -> m a diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs index 9c8af16e..60522020 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -14,6 +14,7 @@ import Data.Set.NonEmpty qualified as NESet import Data.Time (UTCTime) import Data.Time.Clock.POSIX qualified as POSIX import Share.IDs +import Share.Postgres (whenNonEmpty) import Share.Postgres qualified as PG import Share.Postgres.Cursors (PGCursor) import Share.Postgres.Cursors qualified as PG @@ -95,9 +96,9 @@ insertHistoryComments :: AuthZReceipt -> ProjectId -> [HistoryCommentChunk] -> P insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do let thumbprints = NESet.nonEmptySet $ Set.fromList (comments <&> \HistoryComment {authorThumbprint} -> authorThumbprint) for thumbprints insertThumbprints - insertHistoryComments comments - insertRevisions revisions - insertDiscoveryInfo revisions + whenNonEmpty comments $ insertHistoryComments comments + whenNonEmpty revisions $ insertRevisions revisions + whenNonEmpty revisions $ insertDiscoveryInfo revisions pure () where (comments, revisions) = From dadab00383ee92f376d605fcb8f44d84a980807f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 17 Dec 2025 11:14:33 -0800 Subject: [PATCH 19/38] Debug errs --- share-api/src/Share/Web/UCM/HistoryComments/Impl.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index ab2a6ce0..96316340 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -87,8 +87,9 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = Msg chunk -> (Right chunk) DeserialiseFailure msg -> (Left $ UploadCommentsGenericFailure msg) UserErr err -> absurd err - + Debug.debugM Debug.Temp "Processing chunk of size" (length chunk) let (errs, chunks) = partitionEithers chunk + when (not $ null errs) $ Debug.debugM Debug.Temp "Got errors in chunk" (errs) lift $ PG.runTransaction $ Q.insertHistoryComments authZ project.projectId chunks for errs $ \err -> handleErrInQueue q err when (not closed) loop From 01480b610b57d986219e7d4bb9fb577f50d7fa40 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 17 Dec 2025 11:18:42 -0800 Subject: [PATCH 20/38] More debugging --- share-api/src/Share/Web/UCM/HistoryComments/Impl.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 96316340..7da6e270 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -41,7 +41,7 @@ downloadHistoryCommentsStreamImpl _mayUserId _conn = do -- Re-run the given STM action at most n times, collecting the results into a list. -- If the action returns Nothing, stop early and return what has been collected so far, along with a Bool indicating whether the action was exhausted. -fetchChunk :: Int -> STM (Maybe a) -> STM ([a], Bool) +fetchChunk :: (Show a) => Int -> STM (Maybe a) -> STM ([a], Bool) fetchChunk size action = do let go 0 = pure ([], False) go n = do @@ -53,6 +53,7 @@ fetchChunk size action = do -- Queue is closed pure ([], True) Just (Just val) -> do + Debug.debugM Debug.Temp "Fetched value from queue" val (rest, exhausted) <- go (n - 1) pure (val : rest, exhausted) go size @@ -96,8 +97,8 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = loop case result of Left err -> reportError err - Right (Left err) -> reportError err - Right (Right ()) -> pure () + Right (Left err, _leftovers) -> reportError err + Right (Right (), _leftovers) -> pure () where insertCommentBatchSize = 100 handleErrInQueue :: forall o x e. Queues (MsgOrError e UploadCommentsResponse) o -> UploadCommentsResponse -> ExceptT UploadCommentsResponse WebApp x From dde1d87243e4f268652d6cbe966f18981f7c6905 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 17 Dec 2025 12:00:11 -0800 Subject: [PATCH 21/38] Fix up query syntax --- .../src/Share/Web/UCM/HistoryComments/Queries.hs | 15 ++++++++++----- sql/2025-11-20_history-comments.sql | 10 +++++----- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs index 60522020..b543d84a 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -8,6 +8,7 @@ module Share.Web.UCM.HistoryComments.Queries where import Control.Lens +import Data.Foldable qualified as Foldable import Data.Set qualified as Set import Data.Set.NonEmpty (NESet) import Data.Set.NonEmpty qualified as NESet @@ -71,9 +72,12 @@ insertThumbprints :: (PG.QueryA m) => NESet Text -> m () insertThumbprints thumbprints = do PG.execute_ [PG.sql| + WITH thumbprints(thumbprint) AS ( + SELECT * FROM ^{PG.singleColumnTable $ Foldable.toList thumbprints} + ) INSERT INTO personal_keys (thumbprint) - SELECT * FROM ^{PG.singleColumnTable $ toList thumbprints} - ON CONFLICT (thumbprint) DO NOTHING + SELECT thumbprint FROM thumbprints + ON CONFLICT DO NOTHING |] -- Convert milliseconds since epoch to UTCTime _exactly_. @@ -111,18 +115,19 @@ insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do PG.execute_ [PG.sql| WITH new_comments(author, created_at_ms, author_thumbprint, causal_hash, comment_hash) AS ( - VALUES ^{PG.toTable commentsTable} + SELECT * FROM ^{PG.toTable commentsTable} ) INSERT INTO history_comments(causal_id, author, created_at_ms, comment_hash, author_key_id) SELECT causal.id, nc.author, nc.created_at_ms, nc.comment_hash, pk.id FROM new_comments nc - JOIN causal causal + JOIN causals causal ON causal.hash = nc.causal_hash JOIN personal_keys pk ON pk.thumbprint = nc.author_thumbprint - ON CONFLICT DO NOTHING + ON CONFLICT (comment_hash) DO NOTHING |] where + commentsTable :: [(Text, Int64, Text, Hash32, Hash32)] commentsTable = comments <&> \HistoryComment {..} -> ( author, diff --git a/sql/2025-11-20_history-comments.sql b/sql/2025-11-20_history-comments.sql index ca58373c..a70d50ed 100644 --- a/sql/2025-11-20_history-comments.sql +++ b/sql/2025-11-20_history-comments.sql @@ -7,11 +7,11 @@ CREATE TABLE personal_keys ( -- The user registered to this key, which is proven by providing a signed -- assertion using the key. -- It may be null if the key is not yet registered to a user. - user_id INTEGER NULL REFERENCES users(id) ON DELETE SET NULL, - created_at TIMESTAMPTZ NOT NULL, + user_id UUID NULL REFERENCES users(id) ON DELETE SET NULL, + created_at TIMESTAMPTZ NOT NULL DEFAULT NOW(), -- Ensure that public_jwk and user_id are either both null or both non-null. - CHECK (public_jwk IS NULL = user_id IS NULL) + CHECK ((public_jwk IS NULL) = (user_id IS NULL)) ); CREATE INDEX idx_personal_keys_user_id ON personal_keys(user_id, created_at) @@ -59,7 +59,7 @@ CREATE TABLE history_comment_revisions ( revision_hash TEXT UNIQUE NOT NULL, -- The signature of the comment's author on the revision hash. - author_signature BLOB NOT NULL + author_signature BYTEA NOT NULL ); CREATE INDEX idx_history_comment_revisions_comment_id ON history_comment_revisions(comment_id, created_at_ms DESC); @@ -69,7 +69,7 @@ CREATE INDEX idx_history_comment_revisions_comment_id ON history_comment_revisio -- on a given project. CREATE TABLE history_comment_revisions_project_discovery ( comment_revision_id INTEGER NOT NULL REFERENCES history_comment_revisions(id), - project_id INTEGER NOT NULL REFERENCES projects(id), + project_id UUID NOT NULL REFERENCES projects(id), discovered_at TIMESTAMPTZ NOT NULL DEFAULT NOW(), PRIMARY KEY (project_id, comment_revision_id) ); From 746afb82df65cde1192f4932adc8ecfce650c2a8 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 18 Dec 2025 13:16:52 -0800 Subject: [PATCH 22/38] Set up comment negotiation system --- .../src/Share/Web/UCM/HistoryComments/Impl.hs | 102 +++++++++++++----- .../Share/Web/UCM/HistoryComments/Queries.hs | 19 +++- 2 files changed, 88 insertions(+), 33 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 7da6e270..928f1224 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -1,8 +1,11 @@ module Share.Web.UCM.HistoryComments.Impl (server) where +import Control.Concurrent.STM.TBMQueue (TBMQueue, closeTBMQueue, newTBMQueueIO, readTBMQueue, writeTBMQueue) import Control.Monad.Except import Control.Monad.Trans.Maybe -import Data.Either (partitionEithers) +import Data.Set qualified as Set +import Data.Set.NonEmpty qualified as NESet +import Ki.Unlifted qualified as Ki import Network.WebSockets.Connection import Share.IDs import Share.IDs qualified as IDs @@ -18,8 +21,10 @@ import Share.Web.Authorization qualified as AuthZ import Share.Web.Errors (Unimplemented (Unimplemented), reportError, respondError) import Share.Web.UCM.HistoryComments.Queries qualified as Q import Unison.Debug qualified as Debug +import Unison.Hash32 (Hash32) import Unison.Server.HistoryComments.API qualified as HistoryComments -import Unison.Server.HistoryComments.Types (HistoryCommentChunk (..), UploadCommentsResponse (..)) +import Unison.Server.HistoryComments.Types (HistoryCommentDownloaderChunk (..), HistoryCommentUploaderChunk (..), UploadCommentsResponse (..)) +import Unison.Server.HistoryComments.Types qualified as Sync import Unison.Server.Types import Unison.Util.Websockets import UnliftIO @@ -40,7 +45,7 @@ downloadHistoryCommentsStreamImpl _mayUserId _conn = do respondError Unimplemented -- Re-run the given STM action at most n times, collecting the results into a list. --- If the action returns Nothing, stop early and return what has been collected so far, along with a Bool indicating whether the action was exhausted. +-- If the action returns Nothing, stop and return what has been collected so far, along with a Bool indicating whether the action was exhausted. fetchChunk :: (Show a) => Int -> STM (Maybe a) -> STM ([a], Bool) fetchChunk size action = do let go 0 = pure ([], False) @@ -48,60 +53,101 @@ fetchChunk size action = do optional action >>= \case Nothing -> do -- No more values available at the moment - pure ([], False) + empty Just Nothing -> do -- Queue is closed pure ([], True) Just (Just val) -> do Debug.debugM Debug.Temp "Fetched value from queue" val - (rest, exhausted) <- go (n - 1) + (rest, exhausted) <- go (n - 1) <|> pure ([], False) pure (val : rest, exhausted) go size uploadHistoryCommentsStreamImpl :: Maybe UserId -> BranchRef -> Connection -> WebApp () uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = do - Debug.debugM Debug.Temp "uploadHistoryCommentsStreamImpl called with branchRef: " (IDs.toText branchRef, mayCallerUserId) callerUserId <- AuthN.requireAuthenticatedUser' mayCallerUserId - result <- withQueues @(MsgOrError Void UploadCommentsResponse) @(MsgOrError Void HistoryCommentChunk) wsMessageBufferSize wsMessageBufferSize conn \q@(Queues {receive}) -> runExceptT $ do + result <- withQueues @(MsgOrError UploadCommentsResponse HistoryCommentDownloaderChunk) @(MsgOrError Void HistoryCommentUploaderChunk) wsMessageBufferSize wsMessageBufferSize conn \q@(Queues {receive, send}) -> Ki.scoped \scope -> runExceptT $ do projectBranchSH@ProjectBranchShortHand {userHandle, projectSlug, contributorHandle} <- case IDs.fromText @ProjectBranchShortHand branchRef of Left err -> handleErrInQueue q (UploadCommentsGenericFailure $ IDs.toText err) Right pbsh -> pure pbsh let projectSH = ProjectShortHand {userHandle, projectSlug} mayInfo <- lift . runMaybeT $ mapMaybeT PG.runTransaction $ do project <- MaybeT $ PGQ.projectByShortHand projectSH - Debug.debugM Debug.Temp "FOUND PROJECT" (project) branch <- MaybeT $ PGQ.branchByProjectBranchShortHand projectBranchSH - Debug.debugM Debug.Temp "FOUND BRANCH" (branch) contributorUser <- for contributorHandle (MaybeT . UserQ.userByHandle) - Debug.debugM Debug.Temp "FOUND Contributor" (contributorUser) pure (project, branch, contributorUser) (project, _branch, contributorUser) <- maybe (handleErrInQueue q $ UploadCommentsProjectBranchNotFound br) pure $ mayInfo - authZ <- + !authZ <- lift (AuthZ.checkUploadToProjectBranchCodebase callerUserId project.projectId (user_id <$> contributorUser)) >>= \case Left _authErr -> handleErrInQueue q (UploadCommentsNotAuthorized br) Right authZ -> pure authZ - let loop :: ExceptT UploadCommentsResponse WebApp () - loop = do - (chunk, closed) <- atomically $ fetchChunk insertCommentBatchSize do - receive <&> fmap \case - Msg (HistoryCommentErrorChunk err) -> (Left $ UploadCommentsGenericFailure err) - Msg chunk -> (Right chunk) - DeserialiseFailure msg -> (Left $ UploadCommentsGenericFailure msg) - UserErr err -> absurd err - Debug.debugM Debug.Temp "Processing chunk of size" (length chunk) - let (errs, chunks) = partitionEithers chunk - when (not $ null errs) $ Debug.debugM Debug.Temp "Got errors in chunk" (errs) - lift $ PG.runTransaction $ Q.insertHistoryComments authZ project.projectId chunks - for errs $ \err -> handleErrInQueue q err - when (not closed) loop - loop + hashesToCheckQ <- liftIO $ newTBMQueueIO 100 + commentsQ <- liftIO $ newTBMQueueIO 100 + errMVar <- liftIO newEmptyTMVarIO + _receiverThread <- lift $ Ki.fork scope $ receiverWorker receive errMVar hashesToCheckQ commentsQ + inserterThread <- lift $ Ki.fork scope $ inserterWorker authZ commentsQ project.projectId + _hashCheckingThread <- lift $ Ki.fork scope $ hashCheckingWorker send hashesToCheckQ + -- The inserter thread will finish when the client closes the connection. + atomically $ Ki.await inserterThread case result of Left err -> reportError err Right (Left err, _leftovers) -> reportError err Right (Right (), _leftovers) -> pure () where + inserterWorker :: + AuthZ.AuthZReceipt -> + TBMQueue (Either Sync.HistoryComment Sync.HistoryCommentRevision) -> + ProjectId -> + WebApp () + inserterWorker authZ commentsQ projectId = do + let loop = do + (chunk, closed) <- atomically (fetchChunk insertCommentBatchSize (readTBMQueue commentsQ)) + PG.runTransaction $ Q.insertHistoryComments authZ projectId chunk + when (not closed) loop + loop + + hashCheckingWorker :: + (MsgOrError err HistoryCommentDownloaderChunk -> STM Bool) -> + TBMQueue Hash32 -> + WebApp () + hashCheckingWorker send hashesToCheckQ = do + let loop = do + (hashes, closed) <- atomically (fetchChunk insertCommentBatchSize (readTBMQueue hashesToCheckQ)) + Debug.debugM Debug.Temp "Checking hashes chunk of size" (length hashes) + unknownHashes <- PG.runTransaction $ do Q.filterForUnknownHistoryCommentHashes hashes + case NESet.nonEmptySet (Set.fromList unknownHashes) of + Nothing -> pure () + Just unknownHashesSet -> do + void . atomically $ send $ Msg $ RequestCommentsChunk unknownHashesSet + when (not closed) loop + loop + receiverWorker :: STM (Maybe (MsgOrError Void HistoryCommentUploaderChunk)) -> TMVar Text -> TBMQueue Hash32 -> TBMQueue (Either Sync.HistoryComment Sync.HistoryCommentRevision) -> WebApp () + receiverWorker recv errMVar hashesToCheckQ commentsQ = do + let loop = do + next <- atomically do + recv >>= \case + Nothing -> do + closeTBMQueue hashesToCheckQ + closeTBMQueue commentsQ + pure (pure ()) + Just (DeserialiseFailure err) -> do + putTMVar errMVar err + pure (pure ()) + Just (Msg msg) -> do + case msg of + PossiblyNewHashesChunk hashesToCheck -> do + for_ hashesToCheck $ \h -> writeTBMQueue hashesToCheckQ h + DoneSendingHashesChunk -> do + closeTBMQueue hashesToCheckQ + HistoryCommentChunk comment -> do + writeTBMQueue commentsQ (Left comment) + HistoryCommentRevisionChunk revision -> do + writeTBMQueue commentsQ (Right revision) + pure loop + next + loop insertCommentBatchSize = 100 - handleErrInQueue :: forall o x e. Queues (MsgOrError e UploadCommentsResponse) o -> UploadCommentsResponse -> ExceptT UploadCommentsResponse WebApp x + handleErrInQueue :: forall o x e a. Queues (MsgOrError e a) o -> e -> ExceptT e WebApp x handleErrInQueue Queues {send} e = do - _ <- atomically $ send $ Msg e + _ <- atomically $ send $ UserErr e throwError e diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs index b543d84a..9c648985 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -4,6 +4,7 @@ module Share.Web.UCM.HistoryComments.Queries ( fetchProjectBranchCommentsSince, insertHistoryComments, + filterForUnknownHistoryCommentHashes, ) where @@ -25,7 +26,7 @@ import Share.Web.Authorization (AuthZReceipt) import Unison.Hash32 (Hash32) import Unison.Server.HistoryComments.Types -fetchProjectBranchCommentsSince :: AuthZReceipt -> ProjectId -> CausalId -> UTCTime -> PG.Transaction e (PGCursor HistoryCommentChunk) +fetchProjectBranchCommentsSince :: AuthZReceipt -> ProjectId -> CausalId -> UTCTime -> PG.Transaction e (PGCursor HistoryCommentUploaderChunk) fetchProjectBranchCommentsSince !_authZ projectId causalId sinceTime = do PG.newRowCursor @(Bool, Maybe Text, Maybe Text, Maybe Int64, Maybe Bool, Maybe ByteString, Maybe Hash32, Maybe Hash32, Maybe Text, Maybe Int64, Maybe Text, Maybe Hash32, Maybe Hash32) "fetchProjectBranchCommentsSince" @@ -96,7 +97,7 @@ utcTimeToMillis utcTime = & (* (1_000 :: Rational)) & round -insertHistoryComments :: AuthZReceipt -> ProjectId -> [HistoryCommentChunk] -> PG.Transaction e () +insertHistoryComments :: AuthZReceipt -> ProjectId -> [Either HistoryComment HistoryCommentRevision] -> PG.Transaction e () insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do let thumbprints = NESet.nonEmptySet $ Set.fromList (comments <&> \HistoryComment {authorThumbprint} -> authorThumbprint) for thumbprints insertThumbprints @@ -107,9 +108,8 @@ insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do where (comments, revisions) = chunks & foldMap \case - HistoryCommentChunk comment -> ([comment], []) - HistoryCommentRevisionChunk revision -> ([], [revision]) - HistoryCommentErrorChunk err -> error $ "HistoryCommentErrorChunk: " <> show err -- TODO Handle this + Left comment -> ([comment], []) + Right revision -> ([], [revision]) insertHistoryComments :: [HistoryComment] -> PG.Pipeline e () insertHistoryComments comments = do PG.execute_ @@ -201,3 +201,12 @@ insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do commentHash, utcTimeToMillis createdAt ) + +filterForUnknownHistoryCommentHashes :: (PG.QueryA m) => [Hash32] -> m [Hash32] +filterForUnknownHistoryCommentHashes hashes = do + -- error "TODO: Check whether they're in the project as well." + PG.queryListCol + [PG.sql| + SELECT hash FROM ^{PG.singleColumnTable hashes} AS t(hash) + WHERE hash NOT IN (SELECT comment_hash FROM history_comments) + |] From 1a997118dac85ab648bf3712c8c5fb66ce008ec4 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 5 Jan 2026 11:30:36 -0800 Subject: [PATCH 23/38] Ensure we tell the client when we're done sending hashes --- .../src/Share/Web/UCM/HistoryComments/Impl.hs | 20 +++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 928f1224..4a86f7f4 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -87,6 +87,7 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = _receiverThread <- lift $ Ki.fork scope $ receiverWorker receive errMVar hashesToCheckQ commentsQ inserterThread <- lift $ Ki.fork scope $ inserterWorker authZ commentsQ project.projectId _hashCheckingThread <- lift $ Ki.fork scope $ hashCheckingWorker send hashesToCheckQ + Debug.debugLogM Debug.Temp "Upload history comments: waiting for inserter thread to finish" -- The inserter thread will finish when the client closes the connection. atomically $ Ki.await inserterThread case result of @@ -102,9 +103,12 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = inserterWorker authZ commentsQ projectId = do let loop = do (chunk, closed) <- atomically (fetchChunk insertCommentBatchSize (readTBMQueue commentsQ)) - PG.runTransaction $ Q.insertHistoryComments authZ projectId chunk + PG.whenNonEmpty chunk do + Debug.debugM Debug.Temp "Inserting comments chunk of size" (length chunk) + PG.runTransaction $ Q.insertHistoryComments authZ projectId chunk when (not closed) loop loop + Debug.debugLogM Debug.Temp "Inserter worker finished" hashCheckingWorker :: (MsgOrError err HistoryCommentDownloaderChunk -> STM Bool) -> @@ -114,13 +118,16 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = let loop = do (hashes, closed) <- atomically (fetchChunk insertCommentBatchSize (readTBMQueue hashesToCheckQ)) Debug.debugM Debug.Temp "Checking hashes chunk of size" (length hashes) - unknownHashes <- PG.runTransaction $ do Q.filterForUnknownHistoryCommentHashes hashes - case NESet.nonEmptySet (Set.fromList unknownHashes) of - Nothing -> pure () - Just unknownHashesSet -> do - void . atomically $ send $ Msg $ RequestCommentsChunk unknownHashesSet + PG.whenNonEmpty hashes $ do + unknownHashes <- PG.runTransaction $ do Q.filterForUnknownHistoryCommentHashes hashes + case NESet.nonEmptySet (Set.fromList unknownHashes) of + Nothing -> pure () + Just unknownHashesSet -> do + void . atomically $ send $ Msg $ RequestCommentsChunk unknownHashesSet when (not closed) loop loop + void . atomically $ send $ Msg $ DoneCheckingHashesChunk + Debug.debugLogM Debug.Temp "Hash checking worker finished" receiverWorker :: STM (Maybe (MsgOrError Void HistoryCommentUploaderChunk)) -> TMVar Text -> TBMQueue Hash32 -> TBMQueue (Either Sync.HistoryComment Sync.HistoryCommentRevision) -> WebApp () receiverWorker recv errMVar hashesToCheckQ commentsQ = do let loop = do @@ -146,6 +153,7 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = pure loop next loop + Debug.debugLogM Debug.Temp "Receiver worker finished" insertCommentBatchSize = 100 handleErrInQueue :: forall o x e a. Queues (MsgOrError e a) o -> e -> ExceptT e WebApp x handleErrInQueue Queues {send} e = do From 9ab7f20eb191ee4dc04d5c6ff61096b0c7df463f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 8 Jan 2026 11:56:05 -0800 Subject: [PATCH 24/38] Update sync impl to handle history comments and revisions separately --- .../src/Share/Web/UCM/HistoryComments/Impl.hs | 36 +++++++++++++------ .../Share/Web/UCM/HistoryComments/Queries.hs | 25 ++++++++++--- 2 files changed, 47 insertions(+), 14 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 4a86f7f4..e904b031 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -21,7 +21,6 @@ import Share.Web.Authorization qualified as AuthZ import Share.Web.Errors (Unimplemented (Unimplemented), reportError, respondError) import Share.Web.UCM.HistoryComments.Queries qualified as Q import Unison.Debug qualified as Debug -import Unison.Hash32 (Hash32) import Unison.Server.HistoryComments.API qualified as HistoryComments import Unison.Server.HistoryComments.Types (HistoryCommentDownloaderChunk (..), HistoryCommentUploaderChunk (..), UploadCommentsResponse (..)) import Unison.Server.HistoryComments.Types qualified as Sync @@ -39,8 +38,8 @@ server mayCaller = wsMessageBufferSize :: Int wsMessageBufferSize = 100 -downloadHistoryCommentsStreamImpl :: Maybe UserId -> Connection -> WebApp () -downloadHistoryCommentsStreamImpl _mayUserId _conn = do +downloadHistoryCommentsStreamImpl :: Maybe UserId -> BranchRef -> Connection -> WebApp () +downloadHistoryCommentsStreamImpl _mayUserId _branchRef _conn = do _ <- error "AUTH CHECK HERE" respondError Unimplemented @@ -81,12 +80,12 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = lift (AuthZ.checkUploadToProjectBranchCodebase callerUserId project.projectId (user_id <$> contributorUser)) >>= \case Left _authErr -> handleErrInQueue q (UploadCommentsNotAuthorized br) Right authZ -> pure authZ - hashesToCheckQ <- liftIO $ newTBMQueueIO 100 + hashesToCheckQ <- liftIO $ newTBMQueueIO @(Sync.HistoryCommentHash32, [Sync.HistoryCommentRevisionHash32]) 100 commentsQ <- liftIO $ newTBMQueueIO 100 errMVar <- liftIO newEmptyTMVarIO _receiverThread <- lift $ Ki.fork scope $ receiverWorker receive errMVar hashesToCheckQ commentsQ inserterThread <- lift $ Ki.fork scope $ inserterWorker authZ commentsQ project.projectId - _hashCheckingThread <- lift $ Ki.fork scope $ hashCheckingWorker send hashesToCheckQ + _hashCheckingThread <- lift $ Ki.fork scope $ hashCheckingWorker project.projectId send hashesToCheckQ Debug.debugLogM Debug.Temp "Upload history comments: waiting for inserter thread to finish" -- The inserter thread will finish when the client closes the connection. atomically $ Ki.await inserterThread @@ -111,16 +110,33 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = Debug.debugLogM Debug.Temp "Inserter worker finished" hashCheckingWorker :: + ProjectId -> (MsgOrError err HistoryCommentDownloaderChunk -> STM Bool) -> - TBMQueue Hash32 -> + TBMQueue (Sync.HistoryCommentHash32, [Sync.HistoryCommentRevisionHash32]) -> WebApp () - hashCheckingWorker send hashesToCheckQ = do + hashCheckingWorker projectId send hashesToCheckQ = do let loop = do (hashes, closed) <- atomically (fetchChunk insertCommentBatchSize (readTBMQueue hashesToCheckQ)) Debug.debugM Debug.Temp "Checking hashes chunk of size" (length hashes) PG.whenNonEmpty hashes $ do - unknownHashes <- PG.runTransaction $ do Q.filterForUnknownHistoryCommentHashes hashes - case NESet.nonEmptySet (Set.fromList unknownHashes) of + unknownCommentHashes <- fmap Set.fromList $ PG.runTransaction $ do + Q.filterForUnknownHistoryCommentHashes (Sync.unHistoryCommentHash32 . fst <$> hashes) + let (revisionHashesWeDefinitelyNeed, revisionHashesToCheck) = + hashes + -- Only check revisions for comments that are unknown + & foldMap \case + (commentHash, revisionHashes) + -- If the comment hash is unknown, we need _all_ its revisions, we + -- don't need to check them. + -- Otherwise, we need to check which revisions are unknown. + | Set.member (Sync.unHistoryCommentHash32 commentHash) unknownCommentHashes -> (revisionHashes, []) + | otherwise -> ([], revisionHashes) + unknownRevsFiltered <- PG.runTransaction $ Q.filterForUnknownHistoryCommentRevisionHashes projectId (Sync.unHistoryCommentRevisionHash32 <$> revisionHashesToCheck) + let allNeededHashes = + (Set.map (Left . Sync.HistoryCommentHash32) unknownCommentHashes) + <> (Set.fromList . fmap Right $ revisionHashesWeDefinitelyNeed) + <> (Set.fromList (Right . Sync.HistoryCommentRevisionHash32 <$> unknownRevsFiltered)) + case NESet.nonEmptySet allNeededHashes of Nothing -> pure () Just unknownHashesSet -> do void . atomically $ send $ Msg $ RequestCommentsChunk unknownHashesSet @@ -128,7 +144,7 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = loop void . atomically $ send $ Msg $ DoneCheckingHashesChunk Debug.debugLogM Debug.Temp "Hash checking worker finished" - receiverWorker :: STM (Maybe (MsgOrError Void HistoryCommentUploaderChunk)) -> TMVar Text -> TBMQueue Hash32 -> TBMQueue (Either Sync.HistoryComment Sync.HistoryCommentRevision) -> WebApp () + receiverWorker :: STM (Maybe (MsgOrError Void HistoryCommentUploaderChunk)) -> TMVar Text -> TBMQueue (Sync.HistoryCommentHash32, [Sync.HistoryCommentRevisionHash32]) -> TBMQueue (Either Sync.HistoryComment Sync.HistoryCommentRevision) -> WebApp () receiverWorker recv errMVar hashesToCheckQ commentsQ = do let loop = do next <- atomically do diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs index 9c648985..7ff3ecd4 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -5,6 +5,7 @@ module Share.Web.UCM.HistoryComments.Queries ( fetchProjectBranchCommentsSince, insertHistoryComments, filterForUnknownHistoryCommentHashes, + filterForUnknownHistoryCommentRevisionHashes, ) where @@ -203,10 +204,26 @@ insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do ) filterForUnknownHistoryCommentHashes :: (PG.QueryA m) => [Hash32] -> m [Hash32] -filterForUnknownHistoryCommentHashes hashes = do - -- error "TODO: Check whether they're in the project as well." +filterForUnknownHistoryCommentHashes commentHashes = do PG.queryListCol [PG.sql| - SELECT hash FROM ^{PG.singleColumnTable hashes} AS t(hash) - WHERE hash NOT IN (SELECT comment_hash FROM history_comments) + SELECT hash FROM ^{PG.singleColumnTable commentHashes} AS t(hash) + WHERE NOT EXISTS ( + SELECT FROM history_comments hc + WHERE hc.comment_hash = t.hash + ) + |] + +filterForUnknownHistoryCommentRevisionHashes :: (PG.QueryA m) => ProjectId -> [Hash32] -> m [Hash32] +filterForUnknownHistoryCommentRevisionHashes projectId revisionHashes = do + PG.queryListCol + [PG.sql| + SELECT hash FROM ^{PG.singleColumnTable revisionHashes} AS t(hash) + WHERE NOT EXISTS ( + SELECT FROM history_comment_revisions_project_discovery hcrpd + JOIN history_comment_revisions hcr + ON hcrpd.history_comment_revision_id = hcr.id + WHERE hcrpd.project_id = #{projectId} + AND hcr.revision_hash = t.hash + ) |] From d15f38d972b6d80c5e0e48579cc6bed85bdfc30d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 13 Jan 2026 13:56:42 -0800 Subject: [PATCH 25/38] Fix a bunch of comment insertion errors --- .../src/Share/Web/UCM/HistoryComments/Impl.hs | 1 + .../Share/Web/UCM/HistoryComments/Queries.hs | 38 +++++++++---------- sql/2025-11-20_history-comments.sql | 2 +- 3 files changed, 21 insertions(+), 20 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index e904b031..9691138d 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -89,6 +89,7 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = Debug.debugLogM Debug.Temp "Upload history comments: waiting for inserter thread to finish" -- The inserter thread will finish when the client closes the connection. atomically $ Ki.await inserterThread + Debug.debugLogM Debug.Temp "Done. Closing connection." case result of Left err -> reportError err Right (Left err, _leftovers) -> reportError err diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs index 7ff3ecd4..b9bcbb77 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -36,9 +36,9 @@ fetchProjectBranchCommentsSince !_authZ projectId causalId sinceTime = do SELECT hcr.id, hc.id, hcr.subject, hcr.content, hcr.created_at_ms, hcr.is_hidden, hcr.revision_hash, hc.comment_hash, hcr.author_signature history_comment_revisions_project_discovery pd JOIN history_comment_revisions hcr - ON pd.history_comment_revision_id = hcr.id + ON pd.comment_revision_id = hcr.id JOIN history_comments hc - ON hcr.history_comment_id = hc.id + ON hcr.comment_id = hc.id WHERE pd.project_id = #{projectId} AND pd.discovered_at > #{sinceTime} @@ -99,7 +99,7 @@ utcTimeToMillis utcTime = & round insertHistoryComments :: AuthZReceipt -> ProjectId -> [Either HistoryComment HistoryCommentRevision] -> PG.Transaction e () -insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do +insertHistoryComments !_authZ projectId chunks = do let thumbprints = NESet.nonEmptySet $ Set.fromList (comments <&> \HistoryComment {authorThumbprint} -> authorThumbprint) for thumbprints insertThumbprints whenNonEmpty comments $ insertHistoryComments comments @@ -111,7 +111,7 @@ insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do chunks & foldMap \case Left comment -> ([comment], []) Right revision -> ([], [revision]) - insertHistoryComments :: [HistoryComment] -> PG.Pipeline e () + insertHistoryComments :: (PG.QueryA m) => [HistoryComment] -> m () insertHistoryComments comments = do PG.execute_ [PG.sql| @@ -138,13 +138,13 @@ insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do commentHash ) - insertRevisions :: [HistoryCommentRevision] -> PG.Pipeline e () + insertRevisions :: (PG.QueryA m) => [HistoryCommentRevision] -> m () insertRevisions revs = do let doRevs = PG.execute_ [PG.sql| - WITH new_revisions(subject, content, created_at_ms, hidden, author_signature, revision_hash, comment_hash) AS ( - VALUES ^{PG.toTable revsTable} + WITH new_revisions(subject, contents, created_at_ms, hidden, author_signature, revision_hash, comment_hash) AS ( + SELECT * FROM ^{PG.toTable revsTable} ) INSERT INTO history_comment_revisions(comment_id, subject, contents, created_at_ms, hidden, author_signature, revision_hash) SELECT hc.id, nr.subject, nr.contents, nr.created_at_ms, nr.hidden, nr.author_signature, nr.revision_hash @@ -157,12 +157,12 @@ insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do PG.execute_ [PG.sql| WITH new_discoveries(revision_hash) AS ( - VALUES ^{PG.singleColumnTable revHashTable} + SELECT * FROM ^{PG.singleColumnTable revHashTable} ) - INSERT INTO history_comment_revisions_project_discovery(project_id, history_comment_revision_id) + INSERT INTO history_comment_revisions_project_discovery(project_id, comment_revision_id) SELECT #{projectId}, hcr.id FROM new_discoveries nd - JOIN history_comments hcr + JOIN history_comment_revisions hcr ON hcr.revision_hash = nd.revision_hash ON CONFLICT DO NOTHING |] @@ -179,28 +179,28 @@ insertHistoryComments !_authZ projectId chunks = PG.pipelined $ do commentHash ) revHashTable = revs <&> \HistoryCommentRevision {..} -> (revisionHash) - insertDiscoveryInfo :: [HistoryCommentRevision] -> PG.Pipeline e () + insertDiscoveryInfo :: (PG.QueryA m) => [HistoryCommentRevision] -> m () insertDiscoveryInfo revs = do PG.execute_ [PG.sql| - WITH new_discoveries(project_id, history_comment_hash, discovered_at) AS ( - VALUES ^{PG.toTable discoveryTable} + WITH new_discoveries(project_id, history_comment_hash) AS ( + SELECT * FROM ^{PG.toTable discoveryTable} ) - INSERT INTO history_comment_revisions_project_discovery(project_id, history_comment_revision_id, discovered_at) - SELECT #{projectId}, hcr.id, nd.discovered_at + INSERT INTO history_comment_revisions_project_discovery(project_id, comment_revision_id) + SELECT #{projectId}, hcr.id FROM new_discoveries nd JOIN history_comments hc ON hc.comment_hash = nd.history_comment_hash JOIN history_comment_revisions hcr - ON hcr.history_comment_id = hc.id + ON hcr.comment_id = hc.id ON CONFLICT DO NOTHING |] where + discoveryTable :: [(ProjectId, Hash32)] discoveryTable = revs <&> \HistoryCommentRevision {..} -> ( projectId, - commentHash, - utcTimeToMillis createdAt + commentHash ) filterForUnknownHistoryCommentHashes :: (PG.QueryA m) => [Hash32] -> m [Hash32] @@ -222,7 +222,7 @@ filterForUnknownHistoryCommentRevisionHashes projectId revisionHashes = do WHERE NOT EXISTS ( SELECT FROM history_comment_revisions_project_discovery hcrpd JOIN history_comment_revisions hcr - ON hcrpd.history_comment_revision_id = hcr.id + ON hcrpd.comment_revision_id = hcr.id WHERE hcrpd.project_id = #{projectId} AND hcr.revision_hash = t.hash ) diff --git a/sql/2025-11-20_history-comments.sql b/sql/2025-11-20_history-comments.sql index a70d50ed..12e76d08 100644 --- a/sql/2025-11-20_history-comments.sql +++ b/sql/2025-11-20_history-comments.sql @@ -40,7 +40,7 @@ CREATE TABLE history_comments ( CREATE INDEX idx_history_comments_causal_id ON history_comments(causal_id); CREATE TABLE history_comment_revisions ( - id INTEGER PRIMARY KEY, + id SERIAL PRIMARY KEY, comment_id INTEGER NOT NULL REFERENCES history_comments(id), subject TEXT NOT NULL, contents TEXT NOT NULL, From 8c3478ff97856586c6be77e390a28e9920835790 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 13 Jan 2026 14:29:15 -0800 Subject: [PATCH 26/38] Replace old download auth checks with specific HashJWT overrides --- share-api/src/Share/Web/Authorization.hs | 17 ++++++++++------- share-api/src/Share/Web/UCM/Sync/Impl.hs | 6 +++--- share-api/src/Share/Web/UCM/SyncV2/Impl.hs | 4 ++-- 3 files changed, 15 insertions(+), 12 deletions(-) diff --git a/share-api/src/Share/Web/Authorization.hs b/share-api/src/Share/Web/Authorization.hs index fd489671..7ec7c426 100644 --- a/share-api/src/Share/Web/Authorization.hs +++ b/share-api/src/Share/Web/Authorization.hs @@ -43,7 +43,7 @@ module Share.Web.Authorization checkUploadToUserCodebase, checkUploadToProjectBranchCodebase, checkUserUpdate, - checkDownloadFromUserCodebase, + hashJWTAuthOverride, checkDownloadFromProjectBranchCodebase, checkCreateOrg, checkReadOrgRolesList, @@ -389,17 +389,20 @@ checkUploadToUserCodebase reqUserId codebaseOwnerUserId = maybePermissionFailure assertUsersEqual reqUserId codebaseOwnerUserId pure $ AuthZ.UnsafeAuthZReceipt Nothing --- | The download endpoint currently does all of its own auth using HashJWTs, +-- | The download endpoints currently do all of its own auth using HashJWTs, -- So we don't add any other authz checks here, the HashJWT check is sufficient. -checkDownloadFromUserCodebase :: WebApp (Either AuthZFailure AuthZ.AuthZReceipt) -checkDownloadFromUserCodebase = +hashJWTAuthOverride :: WebApp (Either AuthZFailure AuthZ.AuthZReceipt) +hashJWTAuthOverride = pure . Right $ AuthZ.UnsafeAuthZReceipt Nothing -- | The download endpoint currently does all of its own auth using HashJWTs, -- So we don't add any other authz checks here, the HashJWT check is sufficient. -checkDownloadFromProjectBranchCodebase :: WebApp (Either AuthZFailure AuthZ.AuthZReceipt) -checkDownloadFromProjectBranchCodebase = - pure . Right $ AuthZ.UnsafeAuthZReceipt Nothing +checkDownloadFromProjectBranchCodebase :: Maybe UserId -> ProjectId -> WebApp (Either AuthZFailure AuthZ.AuthZReceipt) +checkDownloadFromProjectBranchCodebase reqUserId projectId = + mapLeft (const authzError) <$> do + checkProjectGet reqUserId projectId + where + authzError = AuthZFailure $ (ProjectPermission (ProjectBranchBrowse projectId)) checkProjectCreate :: UserId -> UserId -> WebApp (Either AuthZFailure AuthZ.AuthZReceipt) checkProjectCreate reqUserId targetUserId = maybePermissionFailure (ProjectPermission (ProjectCreate targetUserId)) $ do diff --git a/share-api/src/Share/Web/UCM/Sync/Impl.hs b/share-api/src/Share/Web/UCM/Sync/Impl.hs index e214134c..2bbedf1a 100644 --- a/share-api/src/Share/Web/UCM/Sync/Impl.hs +++ b/share-api/src/Share/Web/UCM/Sync/Impl.hs @@ -149,7 +149,7 @@ downloadEntitiesEndpoint mayUserId DownloadEntitiesRequest {repoInfo, hashes = h Left err -> throwError (DownloadEntitiesFailure $ DownloadEntitiesInvalidRepoInfo err repoInfo) Right (RepoInfoUser userHandle) -> do User {user_id = repoOwnerUserId} <- lift (PG.runTransaction (UserQ.userByHandle userHandle)) `whenNothingM` throwError (DownloadEntitiesFailure . DownloadEntitiesUserNotFound $ IDs.toText @UserHandle userHandle) - authZToken <- lift AuthZ.checkDownloadFromUserCodebase `whenLeftM` \_err -> throwError (DownloadEntitiesFailure $ DownloadEntitiesNoReadPermission repoInfo) + authZToken <- lift AuthZ.hashJWTAuthOverride `whenLeftM` \_err -> throwError (DownloadEntitiesFailure $ DownloadEntitiesNoReadPermission repoInfo) let codebaseLoc = Codebase.codebaseLocationForUserCodebase repoOwnerUserId pure $ Codebase.codebaseEnv authZToken codebaseLoc Right (RepoInfoProjectBranch ProjectBranchShortHand {userHandle, projectSlug, contributorHandle}) -> do @@ -158,7 +158,7 @@ downloadEntitiesEndpoint mayUserId DownloadEntitiesRequest {repoInfo, hashes = h project <- (PGQ.projectByShortHand projectShortHand) `whenNothingM` throwError (DownloadEntitiesFailure . DownloadEntitiesProjectNotFound $ IDs.toText @ProjectShortHand projectShortHand) mayContributorUserId <- for contributorHandle \ch -> fmap user_id $ (UserQ.userByHandle ch) `whenNothingM` throwError (DownloadEntitiesFailure . DownloadEntitiesUserNotFound $ IDs.toText @UserHandle ch) pure (project, mayContributorUserId) - authZToken <- lift AuthZ.checkDownloadFromProjectBranchCodebase `whenLeftM` \_err -> throwError (DownloadEntitiesFailure $ DownloadEntitiesNoReadPermission repoInfo) + authZToken <- lift AuthZ.hashJWTAuthOverride `whenLeftM` \_err -> throwError (DownloadEntitiesFailure $ DownloadEntitiesNoReadPermission repoInfo) let codebaseLoc = Codebase.codebaseLocationForProjectBranchCodebase projectOwnerUserId contributorId pure $ Codebase.codebaseEnv authZToken codebaseLoc Right (RepoInfoProjectRelease ProjectReleaseShortHand {userHandle, projectSlug}) -> do @@ -166,7 +166,7 @@ downloadEntitiesEndpoint mayUserId DownloadEntitiesRequest {repoInfo, hashes = h (Project {ownerUserId = projectOwnerUserId}, contributorId) <- ExceptT . PG.tryRunTransaction $ do project <- PGQ.projectByShortHand projectShortHand `whenNothingM` throwError (DownloadEntitiesFailure . DownloadEntitiesProjectNotFound $ IDs.toText @ProjectShortHand projectShortHand) pure (project, Nothing) - authZToken <- lift AuthZ.checkDownloadFromProjectBranchCodebase `whenLeftM` \_err -> throwError (DownloadEntitiesFailure $ DownloadEntitiesNoReadPermission repoInfo) + authZToken <- lift AuthZ.hashJWTAuthOverride `whenLeftM` \_err -> throwError (DownloadEntitiesFailure $ DownloadEntitiesNoReadPermission repoInfo) let codebaseLoc = Codebase.codebaseLocationForProjectBranchCodebase projectOwnerUserId contributorId pure $ Codebase.codebaseEnv authZToken codebaseLoc Env.Env {maxParallelismPerDownloadRequest} <- ask diff --git a/share-api/src/Share/Web/UCM/SyncV2/Impl.hs b/share-api/src/Share/Web/UCM/SyncV2/Impl.hs index 161376c4..1fba40ce 100644 --- a/share-api/src/Share/Web/UCM/SyncV2/Impl.hs +++ b/share-api/src/Share/Web/UCM/SyncV2/Impl.hs @@ -146,7 +146,7 @@ codebaseForBranchRef branchRef = do (Project {ownerUserId = projectOwnerUserId}, contributorId) <- ExceptT . PG.tryRunTransaction $ do project <- PGQ.projectByShortHand projectShortHand `whenNothingM` throwError (CodebaseLoadingErrorProjectNotFound $ projectShortHand) pure (project, Nothing) - authZToken <- lift AuthZ.checkDownloadFromProjectBranchCodebase `whenLeftM` \_err -> throwError (CodebaseLoadingErrorNoReadPermission branchRef) + authZToken <- lift AuthZ.hashJWTAuthOverride `whenLeftM` \_err -> throwError (CodebaseLoadingErrorNoReadPermission branchRef) let codebaseLoc = Codebase.codebaseLocationForProjectBranchCodebase projectOwnerUserId contributorId pure $ Codebase.codebaseEnv authZToken codebaseLoc Right (Right (ProjectBranchShortHand {userHandle, projectSlug, contributorHandle})) -> do @@ -155,6 +155,6 @@ codebaseForBranchRef branchRef = do project <- (PGQ.projectByShortHand projectShortHand) `whenNothingM` throwError (CodebaseLoadingErrorProjectNotFound projectShortHand) mayContributorUserId <- for contributorHandle \ch -> fmap user_id $ (UserQ.userByHandle ch) `whenNothingM` throwError (CodebaseLoadingErrorUserNotFound ch) pure (project, mayContributorUserId) - authZToken <- lift AuthZ.checkDownloadFromProjectBranchCodebase `whenLeftM` \_err -> throwError (CodebaseLoadingErrorNoReadPermission branchRef) + authZToken <- lift AuthZ.hashJWTAuthOverride `whenLeftM` \_err -> throwError (CodebaseLoadingErrorNoReadPermission branchRef) let codebaseLoc = Codebase.codebaseLocationForProjectBranchCodebase projectOwnerUserId contributorId pure $ Codebase.codebaseEnv authZToken codebaseLoc From a9de783b60afc44336441d27a67080ab1ef0f12d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 13 Jan 2026 14:29:15 -0800 Subject: [PATCH 27/38] Add cursor over history comments query functions --- share-api/src/Share/Postgres/Orphans.hs | 7 ++- .../Share/Web/UCM/HistoryComments/Queries.hs | 55 ++++++++----------- 2 files changed, 28 insertions(+), 34 deletions(-) diff --git a/share-api/src/Share/Postgres/Orphans.hs b/share-api/src/Share/Postgres/Orphans.hs index d9e38bd0..0f427908 100644 --- a/share-api/src/Share/Postgres/Orphans.hs +++ b/share-api/src/Share/Postgres/Orphans.hs @@ -33,10 +33,11 @@ import U.Codebase.TermEdit qualified as TermEdit import U.Util.Base32Hex qualified as Base32Hex import Unison.Hash (Hash) import Unison.Hash qualified as Hash -import Unison.Hash32 (Hash32) +import Unison.Hash32 (Hash32 (..)) import Unison.Hash32 qualified as Hash32 import Unison.Name (Name) import Unison.NameSegment.Internal (NameSegment (..)) +import Unison.Server.HistoryComments.Types import Unison.SyncV2.Types (CBORBytes (..)) import Unison.Syntax.Name qualified as Name import UnliftIO (MonadUnliftIO (..)) @@ -103,6 +104,10 @@ deriving via Hash instance FromHttpApiData ComponentHash deriving via Hash instance ToHttpApiData ComponentHash +deriving via Hash32 instance Hasql.DecodeValue HistoryCommentHash32 + +deriving via Hash32 instance Hasql.DecodeValue HistoryCommentRevisionHash32 + deriving via Text instance Hasql.DecodeValue NameSegment deriving via Text instance Hasql.EncodeValue NameSegment diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs index b9bcbb77..7ecba667 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RecordWildCards #-} module Share.Web.UCM.HistoryComments.Queries - ( fetchProjectBranchCommentsSince, + ( projectBranchCommentsCursor, insertHistoryComments, filterForUnknownHistoryCommentHashes, filterForUnknownHistoryCommentRevisionHashes, @@ -27,48 +27,37 @@ import Share.Web.Authorization (AuthZReceipt) import Unison.Hash32 (Hash32) import Unison.Server.HistoryComments.Types -fetchProjectBranchCommentsSince :: AuthZReceipt -> ProjectId -> CausalId -> UTCTime -> PG.Transaction e (PGCursor HistoryCommentUploaderChunk) -fetchProjectBranchCommentsSince !_authZ projectId causalId sinceTime = do - PG.newRowCursor @(Bool, Maybe Text, Maybe Text, Maybe Int64, Maybe Bool, Maybe ByteString, Maybe Hash32, Maybe Hash32, Maybe Text, Maybe Int64, Maybe Text, Maybe Hash32, Maybe Hash32) - "fetchProjectBranchCommentsSince" +projectBranchCommentsCursor :: AuthZReceipt -> CausalId -> PG.Transaction e (PGCursor (HistoryCommentHash32, HistoryCommentRevisionHash32)) +projectBranchCommentsCursor !_authZ causalId = do + PG.newRowCursor @(HistoryCommentHash32, HistoryCommentRevisionHash32) + "projectBranchCommentsCursor" [PG.sql| - WITH revisions(id, comment_id, subject, contents, created_at_ms, hidden, revision_hash, comment_hash, author_signature) AS ( + WITH history(causal_Id) AS ( + SELECT causal_id FROM causal_history(#{causalId}) + ), revisions(id, comment_id, subject, contents, created_at_ms, hidden, revision_hash, comment_hash, author_signature) AS ( SELECT hcr.id, hc.id, hcr.subject, hcr.content, hcr.created_at_ms, hcr.is_hidden, hcr.revision_hash, hc.comment_hash, hcr.author_signature - history_comment_revisions_project_discovery pd - JOIN history_comment_revisions hcr - ON pd.comment_revision_id = hcr.id + FROM history JOIN history_comments hc + ON hc.causal_id = history.causal_id + JOIN history_comment_revisions hcr ON hcr.comment_id = hc.id WHERE - pd.project_id = #{projectId} - AND pd.discovered_at > #{sinceTime} - AND hc.causal_id IN (SELECT causal_id FROM causal_history(#{causalId})) - ) (SELECT true, NULL, NULL, NULL, NULL, NULL, NULL, NULL, hc.author, hc.created_at_ms, key.thumbprint, causal.hash, hc.comment_hash - FROM revisions rev + hc.causal_id IN () + ) SELECT hc.comment_hash, hcr.revision_hash + FROM history JOIN history_comments hc - ON revisions.comment_id = hc.id + ON hc.causal_id = history.causal_id JOIN causals causal ON hc.causal_id = causal.id JOIN personal_keys key ON hc.author_key_id = key.id - ) - UNION ALL - -- Include ALL the base comments regardless of time, - -- the vast majority of the time we'll need them, it simplifies logic, - -- and the client can just ignore them if they already have them. - (SELECT DISTINCT ON (rev.comment_id) - false, rev.subject, rev.content, rev.created_at_ms, rev.is_hidden, rev.author_signature, rev.revision_hash, rev.comment_hash, NULL, NULL, NULL, NULL, NULL - FROM revisions rev + JOIN LATERAL ( + SELECT * FROM revisions rev + WHERE rev.comment_id = hc.id + ORDER BY rev.created_at_ms DESC + LIMIT 1 ) |] - <&> fmap \case - (True, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Just author, Just createdAtMs, Just authorThumbprint, Just causalHash, Just commentHash) -> - let createdAt = millisToUTCTime createdAtMs - in HistoryCommentChunk $ HistoryComment {..} - (False, Just subject, Just content, Just createdAtMs, Just isHidden, Just authorSignature, Just revisionHash, Just commentHash, Nothing, Nothing, Nothing, Nothing, Nothing) -> - let createdAt = millisToUTCTime createdAtMs - in HistoryCommentRevisionChunk $ HistoryCommentRevision {..} - row -> error $ "fetchProjectBranchCommentsSince: Unexpected row format: " <> show row insertThumbprints :: (PG.QueryA m) => NESet Text -> m () insertThumbprints thumbprints = do @@ -84,8 +73,8 @@ insertThumbprints thumbprints = do -- Convert milliseconds since epoch to UTCTime _exactly_. -- UTCTime has picosecond precision so this is lossless. -millisToUTCTime :: Int64 -> UTCTime -millisToUTCTime ms = +_millisToUTCTime :: Int64 -> UTCTime +_millisToUTCTime ms = toRational ms & (/ (1_000 :: Rational)) & fromRational From 5193f4c93873176c57fe5879ef6a78dd59b9a4de Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 13 Jan 2026 14:29:15 -0800 Subject: [PATCH 28/38] Write downloading queries --- share-api/src/Share/Postgres/Orphans.hs | 4 + .../src/Share/Web/UCM/HistoryComments/Impl.hs | 161 +++++++++++++++++- .../Share/Web/UCM/HistoryComments/Queries.hs | 71 ++++++++ 3 files changed, 228 insertions(+), 8 deletions(-) diff --git a/share-api/src/Share/Postgres/Orphans.hs b/share-api/src/Share/Postgres/Orphans.hs index 0f427908..a549d79d 100644 --- a/share-api/src/Share/Postgres/Orphans.hs +++ b/share-api/src/Share/Postgres/Orphans.hs @@ -106,8 +106,12 @@ deriving via Hash instance ToHttpApiData ComponentHash deriving via Hash32 instance Hasql.DecodeValue HistoryCommentHash32 +deriving via Hash32 instance Hasql.EncodeValue HistoryCommentHash32 + deriving via Hash32 instance Hasql.DecodeValue HistoryCommentRevisionHash32 +deriving via Hash32 instance Hasql.EncodeValue HistoryCommentRevisionHash32 + deriving via Text instance Hasql.DecodeValue NameSegment deriving via Text instance Hasql.EncodeValue NameSegment diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 9691138d..5204cc9b 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -1,8 +1,11 @@ module Share.Web.UCM.HistoryComments.Impl (server) where import Control.Concurrent.STM.TBMQueue (TBMQueue, closeTBMQueue, newTBMQueueIO, readTBMQueue, writeTBMQueue) +import Control.Lens import Control.Monad.Except import Control.Monad.Trans.Maybe +import Data.List.NonEmpty qualified as NEL +import Data.Monoid (Any (..)) import Data.Set qualified as Set import Data.Set.NonEmpty qualified as NESet import Ki.Unlifted qualified as Ki @@ -10,6 +13,7 @@ import Network.WebSockets.Connection import Share.IDs import Share.IDs qualified as IDs import Share.Postgres qualified as PG +import Share.Postgres.Cursors qualified as Cursor import Share.Postgres.Queries qualified as PGQ import Share.Postgres.Users.Queries qualified as UserQ import Share.Prelude @@ -18,7 +22,7 @@ import Share.User import Share.Web.App (WebApp, WebAppServer) import Share.Web.Authentication qualified as AuthN import Share.Web.Authorization qualified as AuthZ -import Share.Web.Errors (Unimplemented (Unimplemented), reportError, respondError) +import Share.Web.Errors (reportError) import Share.Web.UCM.HistoryComments.Queries qualified as Q import Unison.Debug qualified as Debug import Unison.Server.HistoryComments.API qualified as HistoryComments @@ -39,9 +43,131 @@ wsMessageBufferSize :: Int wsMessageBufferSize = 100 downloadHistoryCommentsStreamImpl :: Maybe UserId -> BranchRef -> Connection -> WebApp () -downloadHistoryCommentsStreamImpl _mayUserId _branchRef _conn = do - _ <- error "AUTH CHECK HERE" - respondError Unimplemented +downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = do + result <- withQueues @(MsgOrError Sync.DownloadCommentsResponse HistoryCommentUploaderChunk) @(MsgOrError Void HistoryCommentDownloaderChunk) wsMessageBufferSize wsMessageBufferSize conn \q@(Queues {receive, send}) -> Ki.scoped \scope -> runExceptT $ do + projectBranchSH@ProjectBranchShortHand {userHandle, projectSlug, contributorHandle} <- case IDs.fromText @ProjectBranchShortHand branchRef of + Left err -> handleErrInQueue q (Sync.DownloadCommentsGenericFailure $ IDs.toText err) + Right pbsh -> pure pbsh + let projectSH = ProjectShortHand {userHandle, projectSlug} + mayInfo <- lift . runMaybeT $ mapMaybeT PG.runTransaction $ do + project <- MaybeT $ PGQ.projectByShortHand projectSH + branch <- MaybeT $ PGQ.branchByProjectBranchShortHand projectBranchSH + contributorUser <- for contributorHandle (MaybeT . UserQ.userByHandle) + pure (project, branch, contributorUser) + (project, branch, _contributorUser) <- maybe (handleErrInQueue q $ Sync.DownloadCommentsProjectBranchNotFound br) pure $ mayInfo + !authZ <- + lift (AuthZ.checkDownloadFromProjectBranchCodebase mayCallerUserId project.projectId) >>= \case + Left _authErr -> handleErrInQueue q (Sync.DownloadCommentsNotAuthorized br) + Right authZ -> pure authZ + commentHashesToSendQ <- liftIO $ newTBMQueueIO @(Sync.HistoryCommentHash32, [Sync.HistoryCommentRevisionHash32]) 100 + commentsToSendQ <- liftIO $ newTBMQueueIO @(Either Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32) 100 + -- Is filled when the server notifies us it's done requesting comments + doneRequestingCommentsMVar <- newEmptyTMVarIO + errMVar <- newEmptyTMVarIO + _ <- liftIO $ Ki.fork scope (hashNotifyWorker send commentHashesToSendQ) + senderThread <- liftIO $ Ki.fork scope (senderWorker send commentsToSendQ) + _ <- liftIO $ Ki.fork scope (receiverWorker receive commentsToSendQ errMVar doneRequestingCommentsMVar downloadableCommentsVar) + downloadableCommentsVar <- + liftIO $ newTVarIO @_ @(Set (Either Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32)) Set.empty + PG.runTransaction $ do + cursor <- Q.projectBranchCommentsCursor authZ branch.causal + Cursor.foldBatched cursor 100 \hashes -> do + let (newHashes, chunks) = + hashes + & foldMap + ( \(commentHash, revisionHash) -> + ([Left commentHash, Right revisionHash], [(commentHash, [revisionHash])]) + ) + & first Set.fromList + atomically $ do + modifyTVar downloadableCommentsVar (Set.union newHashes) + for chunks \chunk -> writeTBMQueue commentHashesToSendQ (chunk) + -- Close the hashes queue to signal we don't have any more, then wait for the notifier to finish + atomically $ closeTBMQueue commentHashesToSendQ + -- Once the comment Hash queue is closed, eventually we'll send a DoneSendingHashesChunk message, + -- the server will respond with a DoneCheckingHashesChunk message after it's made all necessary + -- requests. + -- + -- Then we can close the comment upload hash queue to signal we won't get any more upload requests. + atomically $ readTMVar doneRequestingCommentsMVar >> closeTBMQueue commentHashesToSendQ + -- Now we just have to wait for the sender to finish sending all the comments we have queued up. + -- Once we've uploaded everything we can safely exit and the connection will be closed. + atomically $ Ki.await senderThread + case result of + Left err -> do + reportError err + Right (Left err, _leftovers {- Messages sent by server after we finished. -}) -> do + reportError err + Right (Right (), _leftovers {- Messages sent by server after we finished. -}) -> do + pure () + where + senderWorker :: + ( MsgOrError err HistoryCommentUploaderChunk -> + STM Bool + ) -> + TBMQueue (Either Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32) -> + IO () + senderWorker send commentsToSendQ = do + let loop = do + (hashesToSend, isClosed) <- atomically $ flushTBMQueue commentsToSendQ + -- Send comments first, then revisions + withComments <- Q.historyCommentsByHashOf (traversed . _Left) hashesToSend + withCommentsAndRevisions <- Q.historyCommentRevisionsByHashOf (traversed . _Right) withComments + for withCommentsAndRevisions \commentOrRevision -> atomically . send . Msg $ intoChunk commentOrRevision + guard (not isClosed) + loop + void . runMaybeT $ loop + + receiverWorker :: + STM (Maybe (MsgOrError err HistoryCommentDownloaderChunk)) -> + TBMQueue + ( Either + Sync.HistoryCommentHash32 + Sync.HistoryCommentRevisionHash32 + ) -> + TMVar Text -> + TMVar () -> + (TVar (Set (Either Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32))) -> + IO () + receiverWorker receive toUploadQ errMVar doneRequestingCommentsMVar downloadableCommentsVar = do + let loop = do + msgOrError <- atomically receive + case msgOrError of + -- Channel closed, shut down + Nothing -> pure () + Just (Msg msg) -> case msg of + DoneCheckingHashesChunk -> do + -- Notify that the server is done requesting comments + atomically $ putTMVar doneRequestingCommentsMVar () + loop + RequestCommentsChunk comments -> do + atomically $ do + downloadableComments <- readTVar downloadableCommentsVar + let validComments = Set.intersection (NESet.toSet comments) downloadableComments + for_ validComments $ writeTBMQueue toUploadQ + loop + Just (DeserialiseFailure msg) -> do + atomically $ putTMVar errMVar $ "uploadHistoryComments: deserialisation failure: " <> msg + Just (UserErr err) -> do + atomically $ putTMVar errMVar $ "uploadHistoryComments: server error: " <> tShow err + loop + + hashNotifyWorker :: (MsgOrError Sync.DownloadCommentsResponse HistoryCommentUploaderChunk -> STM Bool) -> TBMQueue (Sync.HistoryCommentHash32, [Sync.HistoryCommentRevisionHash32]) -> IO () + hashNotifyWorker send q = do + let loop = do + isClosed <- atomically $ do + (hashesToCheck, isClosed) <- flushTBMQueue q + Any serverClosed <- + NEL.nonEmpty hashesToCheck & foldMapM \possiblyNewHashes -> do + Any <$> (send $ Msg $ PossiblyNewHashesChunk possiblyNewHashes) + pure (isClosed || serverClosed) + if isClosed + then do + -- If the queue is closed, send a DoneCheckingHashesChunk to notify the server we're done. + void . atomically $ send (Msg DoneSendingHashesChunk) + else loop + loop + intoChunk = either HistoryCommentChunk HistoryCommentRevisionChunk -- Re-run the given STM action at most n times, collecting the results into a list. -- If the action returns Nothing, stop and return what has been collected so far, along with a Bool indicating whether the action was exhausted. @@ -106,6 +232,7 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = PG.whenNonEmpty chunk do Debug.debugM Debug.Temp "Inserting comments chunk of size" (length chunk) PG.runTransaction $ Q.insertHistoryComments authZ projectId chunk + when closed $ Debug.debugLogM Debug.Temp "Inserter worker: comments queue closed" when (not closed) loop loop Debug.debugLogM Debug.Temp "Inserter worker finished" @@ -140,7 +267,9 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = case NESet.nonEmptySet allNeededHashes of Nothing -> pure () Just unknownHashesSet -> do + Debug.debugM Debug.Temp "Requesting unknown hashes" unknownHashesSet void . atomically $ send $ Msg $ RequestCommentsChunk unknownHashesSet + when closed $ Debug.debugLogM Debug.Temp "Hash checking worker: hashes queue closed" when (not closed) loop loop void . atomically $ send $ Msg $ DoneCheckingHashesChunk @@ -151,10 +280,12 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = next <- atomically do recv >>= \case Nothing -> do + Debug.debugLogM Debug.Temp "Receiver worker: connection closed" closeTBMQueue hashesToCheckQ closeTBMQueue commentsQ pure (pure ()) Just (DeserialiseFailure err) -> do + Debug.debugM Debug.Temp "Receiver worker: deserialisation failure" err putTMVar errMVar err pure (pure ()) Just (Msg msg) -> do @@ -172,7 +303,21 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = loop Debug.debugLogM Debug.Temp "Receiver worker finished" insertCommentBatchSize = 100 - handleErrInQueue :: forall o x e a. Queues (MsgOrError e a) o -> e -> ExceptT e WebApp x - handleErrInQueue Queues {send} e = do - _ <- atomically $ send $ UserErr e - throwError e + +handleErrInQueue :: forall o x e a. Queues (MsgOrError e a) o -> e -> ExceptT e WebApp x +handleErrInQueue Queues {send} e = do + _ <- atomically $ send $ UserErr e + throwError e + +-- Read all available values from a TBMQueue, returning them and whether the queue is closed. +flushTBMQueue :: TBMQueue a -> STM ([a], Bool) +flushTBMQueue q = do + optional (readTBMQueue q) >>= \case + -- No values available + Nothing -> empty + Just Nothing -> do + -- Queue closed + pure ([], True) + Just (Just v) -> do + (vs, closed) <- flushTBMQueue q <|> pure ([], False) + pure (v : vs, closed) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs index 7ecba667..eb76a6be 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -4,6 +4,8 @@ module Share.Web.UCM.HistoryComments.Queries ( projectBranchCommentsCursor, insertHistoryComments, + historyCommentsByHashOf, + historyCommentRevisionsByHashOf, filterForUnknownHistoryCommentHashes, filterForUnknownHistoryCommentRevisionHashes, ) @@ -23,6 +25,7 @@ import Share.Postgres.Cursors (PGCursor) import Share.Postgres.Cursors qualified as PG import Share.Postgres.IDs import Share.Prelude +import Share.Utils.Postgres (ordered) import Share.Web.Authorization (AuthZReceipt) import Unison.Hash32 (Hash32) import Unison.Server.HistoryComments.Types @@ -59,6 +62,74 @@ projectBranchCommentsCursor !_authZ causalId = do ) |] +historyCommentsByHashOf :: (PG.QueryA m) => Traversal s t HistoryCommentHash32 HistoryComment -> s -> m t +historyCommentsByHashOf trav s = do + s + & asListOf trav %%~ \hashes -> + PG.queryListRows + [PG.sql| + WITH hashes (hash, ord) AS ( + SELECT * FROM ^{PG.toTable $ ordered hashes} + ) SELECT hc.author, hc.created_at_ms, key.thumbprint, causal.hash AS causal_hash, hc.comment_hash + FROM hashes + JOIN history_comments hc + ON hc.comment_hash = hashes.hash + JOIN causals causal + ON hc.causal_id = causal.id + JOIN personal_keys key + ON hc.author_key_id = key.id + ORDER BY hashes.ord ASC + |] + <&> fmap + \( author, + createdAt, + authorThumbprint, + causalHash, + commentHash + ) -> + HistoryComment + { author, + createdAt, + authorThumbprint, + causalHash, + commentHash + } + +historyCommentRevisionsByHashOf :: (PG.QueryA m) => Traversal s t HistoryCommentRevisionHash32 HistoryCommentRevision -> s -> m t +historyCommentRevisionsByHashOf trav s = do + s + & asListOf trav %%~ \hashes -> do + PG.queryListRows + [PG.sql| + WITH hashes (hash, ord) AS ( + SELECT * FROM ^{PG.toTable $ ordered hashes} + ) SELECT hcr.subject, hcr.content, hcr.created_at_ms, hcr.is_hidden, hcr.author_signature, hcr.revision_hash, hc.comment_hash + FROM hashes + JOIN history_comment_revisions hcr + ON hcr.revision_hash = hashes.hash + JOIN history_comments hc + ON hcr.comment_id = hc.id + ORDER BY hashes.ord ASC + |] + <&> fmap + \( subject, + content, + createdAt, + isHidden, + authorSignature, + revisionHash, + commentHash + ) -> + HistoryCommentRevision + { subject, + content, + createdAt, + isHidden, + authorSignature, + revisionHash, + commentHash + } + insertThumbprints :: (PG.QueryA m) => NESet Text -> m () insertThumbprints thumbprints = do PG.execute_ From 4e5f24eac9d7e4bccaa36a7043f08a2797e1a990 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 14 Jan 2026 14:33:08 -0800 Subject: [PATCH 29/38] More clean up --- share-api/src/Share/Utils/Logging.hs | 14 +++++++- share-api/src/Share/Web/Errors.hs | 11 +++++- .../src/Share/Web/UCM/HistoryComments/Impl.hs | 36 ++++++++++--------- 3 files changed, 43 insertions(+), 18 deletions(-) diff --git a/share-api/src/Share/Utils/Logging.hs b/share-api/src/Share/Utils/Logging.hs index e13d0770..0d98cf39 100644 --- a/share-api/src/Share/Utils/Logging.hs +++ b/share-api/src/Share/Utils/Logging.hs @@ -57,7 +57,7 @@ import Share.Utils.Logging.Types as X import Share.Utils.Tags (MonadTags) import System.Log.FastLogger qualified as FL import Unison.Server.Backend qualified as Backend -import Unison.Server.HistoryComments.Types (UploadCommentsResponse (..)) +import Unison.Server.HistoryComments.Types (DownloadCommentsResponse (..), UploadCommentsResponse (..)) import Unison.Server.Types (BranchRef (..)) import Unison.Sync.Types qualified as Sync import Unison.Util.Monoid (intercalateMap) @@ -285,3 +285,15 @@ instance Loggable UploadCommentsResponse where instance Loggable WS.ConnectionException where toLog = withSeverity Error . showLog + +instance Loggable DownloadCommentsResponse where + toLog = \case + DownloadCommentsProjectBranchNotFound (BranchRef branchRef) -> + textLog ("Project branch not found: " <> branchRef) + & withSeverity UserFault + DownloadCommentsNotAuthorized (BranchRef branchRef) -> + textLog ("Not authorized to download comments from branch: " <> branchRef) + & withSeverity UserFault + DownloadCommentsGenericFailure errMsg -> + textLog ("Download comments generic failure: " <> errMsg) + & withSeverity Error diff --git a/share-api/src/Share/Web/Errors.hs b/share-api/src/Share/Web/Errors.hs index 9d5594f4..7024a64b 100644 --- a/share-api/src/Share/Web/Errors.hs +++ b/share-api/src/Share/Web/Errors.hs @@ -68,7 +68,7 @@ import Share.Utils.URI (URIParam (..), addQueryParam) import Share.Web.App import Unison.Server.Backend qualified as Backend import Unison.Server.Errors qualified as Backend -import Unison.Server.HistoryComments.Types (UploadCommentsResponse (..)) +import Unison.Server.HistoryComments.Types (DownloadCommentsResponse (..), UploadCommentsResponse (..)) import Unison.Server.Types (BranchRef (..)) import Unison.Sync.Types qualified as Sync import UnliftIO qualified @@ -446,3 +446,12 @@ instance ToServerError WS.ConnectionException where (ErrorID "websocket:unicode-exception", err400 {errBody = BL.fromStrict $ Text.encodeUtf8 $ "Unicode decoding exception: " <> Text.pack msg}) WS.ConnectionClosed -> (ErrorID "websocket:connection-closed", err400 {errBody = "WebSocket connection closed"}) + +instance ToServerError DownloadCommentsResponse where + toServerError = \case + DownloadCommentsProjectBranchNotFound (BranchRef branchRef) -> + (ErrorID "download-comments:project-branch-not-found", err404 {errBody = BL.fromStrict $ Text.encodeUtf8 $ "Project branch not found: " <> branchRef}) + DownloadCommentsNotAuthorized (BranchRef branchRef) -> + (ErrorID "download-comments:not-authorized", err403 {errBody = BL.fromStrict $ Text.encodeUtf8 $ "Not authorized to download comments from branch: " <> branchRef}) + DownloadCommentsGenericFailure errMsg -> + (ErrorID "download-comments:generic-failure", err500 {errBody = BL.fromStrict $ Text.encodeUtf8 $ "Download comments failure: " <> errMsg}) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 5204cc9b..ba93300b 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -10,6 +10,7 @@ import Data.Set qualified as Set import Data.Set.NonEmpty qualified as NESet import Ki.Unlifted qualified as Ki import Network.WebSockets.Connection +import Share.Branch import Share.IDs import Share.IDs qualified as IDs import Share.Postgres qualified as PG @@ -59,17 +60,18 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn lift (AuthZ.checkDownloadFromProjectBranchCodebase mayCallerUserId project.projectId) >>= \case Left _authErr -> handleErrInQueue q (Sync.DownloadCommentsNotAuthorized br) Right authZ -> pure authZ + + downloadableCommentsVar <- + liftIO $ newTVarIO @_ @(Set (Either Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32)) Set.empty commentHashesToSendQ <- liftIO $ newTBMQueueIO @(Sync.HistoryCommentHash32, [Sync.HistoryCommentRevisionHash32]) 100 commentsToSendQ <- liftIO $ newTBMQueueIO @(Either Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32) 100 -- Is filled when the server notifies us it's done requesting comments doneRequestingCommentsMVar <- newEmptyTMVarIO errMVar <- newEmptyTMVarIO - _ <- liftIO $ Ki.fork scope (hashNotifyWorker send commentHashesToSendQ) - senderThread <- liftIO $ Ki.fork scope (senderWorker send commentsToSendQ) - _ <- liftIO $ Ki.fork scope (receiverWorker receive commentsToSendQ errMVar doneRequestingCommentsMVar downloadableCommentsVar) - downloadableCommentsVar <- - liftIO $ newTVarIO @_ @(Set (Either Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32)) Set.empty - PG.runTransaction $ do + _ <- lift $ Ki.fork scope (hashNotifyWorker send commentHashesToSendQ) + senderThread <- lift $ Ki.fork scope (senderWorker send commentsToSendQ) + _ <- lift $ Ki.fork scope (receiverWorker receive commentsToSendQ errMVar doneRequestingCommentsMVar downloadableCommentsVar) + lift $ PG.runTransaction $ do cursor <- Q.projectBranchCommentsCursor authZ branch.causal Cursor.foldBatched cursor 100 \hashes -> do let (newHashes, chunks) = @@ -79,7 +81,7 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn ([Left commentHash, Right revisionHash], [(commentHash, [revisionHash])]) ) & first Set.fromList - atomically $ do + PG.transactionUnsafeIO $ atomically $ do modifyTVar downloadableCommentsVar (Set.union newHashes) for chunks \chunk -> writeTBMQueue commentHashesToSendQ (chunk) -- Close the hashes queue to signal we don't have any more, then wait for the notifier to finish @@ -106,20 +108,21 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn STM Bool ) -> TBMQueue (Either Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32) -> - IO () + WebApp () senderWorker send commentsToSendQ = do let loop = do (hashesToSend, isClosed) <- atomically $ flushTBMQueue commentsToSendQ - -- Send comments first, then revisions - withComments <- Q.historyCommentsByHashOf (traversed . _Left) hashesToSend - withCommentsAndRevisions <- Q.historyCommentRevisionsByHashOf (traversed . _Right) withComments + withCommentsAndRevisions <- lift . PG.runTransaction $ do + -- Send comments first, then revisions + withComments <- Q.historyCommentsByHashOf (traversed . _Left) hashesToSend + Q.historyCommentRevisionsByHashOf (traversed . _Right) withComments for withCommentsAndRevisions \commentOrRevision -> atomically . send . Msg $ intoChunk commentOrRevision guard (not isClosed) loop void . runMaybeT $ loop receiverWorker :: - STM (Maybe (MsgOrError err HistoryCommentDownloaderChunk)) -> + STM (Maybe (MsgOrError Void HistoryCommentDownloaderChunk)) -> TBMQueue ( Either Sync.HistoryCommentHash32 @@ -128,7 +131,7 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn TMVar Text -> TMVar () -> (TVar (Set (Either Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32))) -> - IO () + WebApp () receiverWorker receive toUploadQ errMVar doneRequestingCommentsMVar downloadableCommentsVar = do let loop = do msgOrError <- atomically receive @@ -148,11 +151,12 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn loop Just (DeserialiseFailure msg) -> do atomically $ putTMVar errMVar $ "uploadHistoryComments: deserialisation failure: " <> msg - Just (UserErr err) -> do - atomically $ putTMVar errMVar $ "uploadHistoryComments: server error: " <> tShow err loop - hashNotifyWorker :: (MsgOrError Sync.DownloadCommentsResponse HistoryCommentUploaderChunk -> STM Bool) -> TBMQueue (Sync.HistoryCommentHash32, [Sync.HistoryCommentRevisionHash32]) -> IO () + hashNotifyWorker :: + (MsgOrError Sync.DownloadCommentsResponse HistoryCommentUploaderChunk -> STM Bool) -> + TBMQueue (Sync.HistoryCommentHash32, [Sync.HistoryCommentRevisionHash32]) -> + WebApp () hashNotifyWorker send q = do let loop = do isClosed <- atomically $ do From 3901b0950406888096b9aca625d16ce6d0e6d689 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 14 Jan 2026 14:43:28 -0800 Subject: [PATCH 30/38] SQL issues --- .../Share/Web/UCM/HistoryComments/Queries.hs | 27 +++++++------------ 1 file changed, 10 insertions(+), 17 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs index eb76a6be..62fb052e 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -35,17 +35,8 @@ projectBranchCommentsCursor !_authZ causalId = do PG.newRowCursor @(HistoryCommentHash32, HistoryCommentRevisionHash32) "projectBranchCommentsCursor" [PG.sql| - WITH history(causal_Id) AS ( - SELECT causal_id FROM causal_history(#{causalId}) - ), revisions(id, comment_id, subject, contents, created_at_ms, hidden, revision_hash, comment_hash, author_signature) AS ( - SELECT hcr.id, hc.id, hcr.subject, hcr.content, hcr.created_at_ms, hcr.is_hidden, hcr.revision_hash, hc.comment_hash, hcr.author_signature - FROM history - JOIN history_comments hc - ON hc.causal_id = history.causal_id - JOIN history_comment_revisions hcr - ON hcr.comment_id = hc.id - WHERE - hc.causal_id IN () + WITH history(causal_id) AS ( + SELECT ch.causal_id FROM causal_history(#{causalId}) AS ch(causal_id) ) SELECT hc.comment_hash, hcr.revision_hash FROM history JOIN history_comments hc @@ -55,11 +46,13 @@ projectBranchCommentsCursor !_authZ causalId = do JOIN personal_keys key ON hc.author_key_id = key.id JOIN LATERAL ( - SELECT * FROM revisions rev - WHERE rev.comment_id = hc.id - ORDER BY rev.created_at_ms DESC - LIMIT 1 - ) + SELECT rev.revision_hash + FROM history_comment_revisions rev + WHERE rev.comment_id = hc.id + ORDER BY rev.created_at_ms DESC + LIMIT 1 + ) hcr + ON TRUE |] historyCommentsByHashOf :: (PG.QueryA m) => Traversal s t HistoryCommentHash32 HistoryComment -> s -> m t @@ -68,7 +61,7 @@ historyCommentsByHashOf trav s = do & asListOf trav %%~ \hashes -> PG.queryListRows [PG.sql| - WITH hashes (hash, ord) AS ( + WITH hashes (ord, hash) AS ( SELECT * FROM ^{PG.toTable $ ordered hashes} ) SELECT hc.author, hc.created_at_ms, key.thumbprint, causal.hash AS causal_hash, hc.comment_hash FROM hashes From 442daad6f81c2671d2e7a457e13cbd187b01b99d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 14 Jan 2026 15:04:49 -0800 Subject: [PATCH 31/38] Cleanup --- .../src/Share/Web/UCM/HistoryComments/Impl.hs | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index ba93300b..471a9482 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -70,7 +70,7 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn errMVar <- newEmptyTMVarIO _ <- lift $ Ki.fork scope (hashNotifyWorker send commentHashesToSendQ) senderThread <- lift $ Ki.fork scope (senderWorker send commentsToSendQ) - _ <- lift $ Ki.fork scope (receiverWorker receive commentsToSendQ errMVar doneRequestingCommentsMVar downloadableCommentsVar) + _ <- lift $ Ki.fork scope (receiverWorker receive commentsToSendQ commentHashesToSendQ errMVar downloadableCommentsVar) lift $ PG.runTransaction $ do cursor <- Q.projectBranchCommentsCursor authZ branch.causal Cursor.foldBatched cursor 100 \hashes -> do @@ -86,12 +86,6 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn for chunks \chunk -> writeTBMQueue commentHashesToSendQ (chunk) -- Close the hashes queue to signal we don't have any more, then wait for the notifier to finish atomically $ closeTBMQueue commentHashesToSendQ - -- Once the comment Hash queue is closed, eventually we'll send a DoneSendingHashesChunk message, - -- the server will respond with a DoneCheckingHashesChunk message after it's made all necessary - -- requests. - -- - -- Then we can close the comment upload hash queue to signal we won't get any more upload requests. - atomically $ readTMVar doneRequestingCommentsMVar >> closeTBMQueue commentHashesToSendQ -- Now we just have to wait for the sender to finish sending all the comments we have queued up. -- Once we've uploaded everything we can safely exit and the connection will be closed. atomically $ Ki.await senderThread @@ -128,11 +122,11 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32 ) -> + (TBMQueue (Sync.HistoryCommentHash32, [Sync.HistoryCommentRevisionHash32])) -> TMVar Text -> - TMVar () -> (TVar (Set (Either Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32))) -> WebApp () - receiverWorker receive toUploadQ errMVar doneRequestingCommentsMVar downloadableCommentsVar = do + receiverWorker receive commentsToSendQ commentHashesToSendQ errMVar downloadableCommentsVar = do let loop = do msgOrError <- atomically receive case msgOrError of @@ -141,13 +135,13 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn Just (Msg msg) -> case msg of DoneCheckingHashesChunk -> do -- Notify that the server is done requesting comments - atomically $ putTMVar doneRequestingCommentsMVar () + atomically $ closeTBMQueue commentHashesToSendQ loop RequestCommentsChunk comments -> do atomically $ do downloadableComments <- readTVar downloadableCommentsVar let validComments = Set.intersection (NESet.toSet comments) downloadableComments - for_ validComments $ writeTBMQueue toUploadQ + for_ validComments $ writeTBMQueue commentsToSendQ loop Just (DeserialiseFailure msg) -> do atomically $ putTMVar errMVar $ "uploadHistoryComments: deserialisation failure: " <> msg From 946bdf74ba6b08c327825decd498daf11ecdfa57 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 14 Jan 2026 15:07:51 -0800 Subject: [PATCH 32/38] Working! --- .../src/Share/Web/UCM/HistoryComments/Impl.hs | 23 +++++++++---------- .../Share/Web/UCM/HistoryComments/Queries.hs | 4 ++-- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 471a9482..fe614a07 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -5,7 +5,7 @@ import Control.Lens import Control.Monad.Except import Control.Monad.Trans.Maybe import Data.List.NonEmpty qualified as NEL -import Data.Monoid (Any (..)) +import Data.Monoid (All (..)) import Data.Set qualified as Set import Data.Set.NonEmpty qualified as NESet import Ki.Unlifted qualified as Ki @@ -65,12 +65,10 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn liftIO $ newTVarIO @_ @(Set (Either Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32)) Set.empty commentHashesToSendQ <- liftIO $ newTBMQueueIO @(Sync.HistoryCommentHash32, [Sync.HistoryCommentRevisionHash32]) 100 commentsToSendQ <- liftIO $ newTBMQueueIO @(Either Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32) 100 - -- Is filled when the server notifies us it's done requesting comments - doneRequestingCommentsMVar <- newEmptyTMVarIO errMVar <- newEmptyTMVarIO _ <- lift $ Ki.fork scope (hashNotifyWorker send commentHashesToSendQ) senderThread <- lift $ Ki.fork scope (senderWorker send commentsToSendQ) - _ <- lift $ Ki.fork scope (receiverWorker receive commentsToSendQ commentHashesToSendQ errMVar downloadableCommentsVar) + _ <- lift $ Ki.fork scope (receiverWorker receive commentsToSendQ errMVar downloadableCommentsVar) lift $ PG.runTransaction $ do cursor <- Q.projectBranchCommentsCursor authZ branch.causal Cursor.foldBatched cursor 100 \hashes -> do @@ -110,7 +108,7 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn -- Send comments first, then revisions withComments <- Q.historyCommentsByHashOf (traversed . _Left) hashesToSend Q.historyCommentRevisionsByHashOf (traversed . _Right) withComments - for withCommentsAndRevisions \commentOrRevision -> atomically . send . Msg $ intoChunk commentOrRevision + for_ withCommentsAndRevisions \commentOrRevision -> atomically . send . Msg $ intoChunk commentOrRevision guard (not isClosed) loop void . runMaybeT $ loop @@ -122,11 +120,10 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32 ) -> - (TBMQueue (Sync.HistoryCommentHash32, [Sync.HistoryCommentRevisionHash32])) -> TMVar Text -> (TVar (Set (Either Sync.HistoryCommentHash32 Sync.HistoryCommentRevisionHash32))) -> WebApp () - receiverWorker receive commentsToSendQ commentHashesToSendQ errMVar downloadableCommentsVar = do + receiverWorker receive commentsToSendQ errMVar downloadableCommentsVar = do let loop = do msgOrError <- atomically receive case msgOrError of @@ -134,8 +131,10 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn Nothing -> pure () Just (Msg msg) -> case msg of DoneCheckingHashesChunk -> do - -- Notify that the server is done requesting comments - atomically $ closeTBMQueue commentHashesToSendQ + -- The downloader is done checking hashes, and has issued all requests for + -- comments. + -- We can close the relevant queues now, we won't get any more requests. + atomically $ closeTBMQueue commentsToSendQ loop RequestCommentsChunk comments -> do atomically $ do @@ -155,10 +154,10 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn let loop = do isClosed <- atomically $ do (hashesToCheck, isClosed) <- flushTBMQueue q - Any serverClosed <- + All sendSuccess <- NEL.nonEmpty hashesToCheck & foldMapM \possiblyNewHashes -> do - Any <$> (send $ Msg $ PossiblyNewHashesChunk possiblyNewHashes) - pure (isClosed || serverClosed) + All <$> (send $ Msg $ PossiblyNewHashesChunk possiblyNewHashes) + pure (isClosed || not sendSuccess) if isClosed then do -- If the queue is closed, send a DoneCheckingHashesChunk to notify the server we're done. diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs index 62fb052e..5e04dff9 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Queries.hs @@ -94,9 +94,9 @@ historyCommentRevisionsByHashOf trav s = do & asListOf trav %%~ \hashes -> do PG.queryListRows [PG.sql| - WITH hashes (hash, ord) AS ( + WITH hashes (ord, hash) AS ( SELECT * FROM ^{PG.toTable $ ordered hashes} - ) SELECT hcr.subject, hcr.content, hcr.created_at_ms, hcr.is_hidden, hcr.author_signature, hcr.revision_hash, hc.comment_hash + ) SELECT hcr.subject, hcr.contents, hcr.created_at_ms, hcr.hidden, hcr.author_signature, hcr.revision_hash, hc.comment_hash FROM hashes JOIN history_comment_revisions hcr ON hcr.revision_hash = hashes.hash From 499c2dc8e44eae87db69c70c79a6884f0285a892 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 14 Jan 2026 15:30:45 -0800 Subject: [PATCH 33/38] Make debugging more specific --- .../src/Share/Web/UCM/HistoryComments/Impl.hs | 25 +++++++++---------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index fe614a07..7bb919fc 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -180,7 +180,6 @@ fetchChunk size action = do -- Queue is closed pure ([], True) Just (Just val) -> do - Debug.debugM Debug.Temp "Fetched value from queue" val (rest, exhausted) <- go (n - 1) <|> pure ([], False) pure (val : rest, exhausted) go size @@ -209,10 +208,10 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = _receiverThread <- lift $ Ki.fork scope $ receiverWorker receive errMVar hashesToCheckQ commentsQ inserterThread <- lift $ Ki.fork scope $ inserterWorker authZ commentsQ project.projectId _hashCheckingThread <- lift $ Ki.fork scope $ hashCheckingWorker project.projectId send hashesToCheckQ - Debug.debugLogM Debug.Temp "Upload history comments: waiting for inserter thread to finish" + Debug.debugLogM Debug.HistoryComments "Upload history comments: waiting for inserter thread to finish" -- The inserter thread will finish when the client closes the connection. atomically $ Ki.await inserterThread - Debug.debugLogM Debug.Temp "Done. Closing connection." + Debug.debugLogM Debug.HistoryComments "Done. Closing connection." case result of Left err -> reportError err Right (Left err, _leftovers) -> reportError err @@ -227,12 +226,12 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = let loop = do (chunk, closed) <- atomically (fetchChunk insertCommentBatchSize (readTBMQueue commentsQ)) PG.whenNonEmpty chunk do - Debug.debugM Debug.Temp "Inserting comments chunk of size" (length chunk) + Debug.debugM Debug.HistoryComments "Inserting comments chunk of size" (length chunk) PG.runTransaction $ Q.insertHistoryComments authZ projectId chunk - when closed $ Debug.debugLogM Debug.Temp "Inserter worker: comments queue closed" + when closed $ Debug.debugLogM Debug.HistoryComments "Inserter worker: comments queue closed" when (not closed) loop loop - Debug.debugLogM Debug.Temp "Inserter worker finished" + Debug.debugLogM Debug.HistoryComments "Inserter worker finished" hashCheckingWorker :: ProjectId -> @@ -242,7 +241,7 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = hashCheckingWorker projectId send hashesToCheckQ = do let loop = do (hashes, closed) <- atomically (fetchChunk insertCommentBatchSize (readTBMQueue hashesToCheckQ)) - Debug.debugM Debug.Temp "Checking hashes chunk of size" (length hashes) + Debug.debugM Debug.HistoryComments "Checking hashes chunk of size" (length hashes) PG.whenNonEmpty hashes $ do unknownCommentHashes <- fmap Set.fromList $ PG.runTransaction $ do Q.filterForUnknownHistoryCommentHashes (Sync.unHistoryCommentHash32 . fst <$> hashes) @@ -264,25 +263,25 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = case NESet.nonEmptySet allNeededHashes of Nothing -> pure () Just unknownHashesSet -> do - Debug.debugM Debug.Temp "Requesting unknown hashes" unknownHashesSet + Debug.debugM Debug.HistoryComments "Requesting unknown hashes" unknownHashesSet void . atomically $ send $ Msg $ RequestCommentsChunk unknownHashesSet - when closed $ Debug.debugLogM Debug.Temp "Hash checking worker: hashes queue closed" + when closed $ Debug.debugLogM Debug.HistoryComments "Hash checking worker: hashes queue closed" when (not closed) loop loop void . atomically $ send $ Msg $ DoneCheckingHashesChunk - Debug.debugLogM Debug.Temp "Hash checking worker finished" + Debug.debugLogM Debug.HistoryComments "Hash checking worker finished" receiverWorker :: STM (Maybe (MsgOrError Void HistoryCommentUploaderChunk)) -> TMVar Text -> TBMQueue (Sync.HistoryCommentHash32, [Sync.HistoryCommentRevisionHash32]) -> TBMQueue (Either Sync.HistoryComment Sync.HistoryCommentRevision) -> WebApp () receiverWorker recv errMVar hashesToCheckQ commentsQ = do let loop = do next <- atomically do recv >>= \case Nothing -> do - Debug.debugLogM Debug.Temp "Receiver worker: connection closed" + Debug.debugLogM Debug.HistoryComments "Receiver worker: connection closed" closeTBMQueue hashesToCheckQ closeTBMQueue commentsQ pure (pure ()) Just (DeserialiseFailure err) -> do - Debug.debugM Debug.Temp "Receiver worker: deserialisation failure" err + Debug.debugM Debug.HistoryComments "Receiver worker: deserialisation failure" err putTMVar errMVar err pure (pure ()) Just (Msg msg) -> do @@ -298,7 +297,7 @@ uploadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn = pure loop next loop - Debug.debugLogM Debug.Temp "Receiver worker finished" + Debug.debugLogM Debug.HistoryComments "Receiver worker finished" insertCommentBatchSize = 100 handleErrInQueue :: forall o x e a. Queues (MsgOrError e a) o -> e -> ExceptT e WebApp x From 4c0b80e7ce4e4bfc54485459dd342e42997a64bc Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 15 Jan 2026 10:44:43 -0800 Subject: [PATCH 34/38] Set up history-comments transcripts --- transcripts/run-transcripts.zsh | 2 +- .../history-comments/comment-pull.md | 4 ++++ .../share-apis/history-comments/prelude.md | 18 ++++++++++++++++++ .../share-apis/history-comments/run.zsh | 11 +++++++++++ 4 files changed, 34 insertions(+), 1 deletion(-) create mode 100644 transcripts/share-apis/history-comments/comment-pull.md create mode 100644 transcripts/share-apis/history-comments/prelude.md create mode 100755 transcripts/share-apis/history-comments/run.zsh diff --git a/transcripts/run-transcripts.zsh b/transcripts/run-transcripts.zsh index 2a5f0c2d..5dd27bb0 100755 --- a/transcripts/run-transcripts.zsh +++ b/transcripts/run-transcripts.zsh @@ -21,7 +21,7 @@ transcripts_location="transcripts/share-apis" for dir in "$transcripts_location"/*(/); do # Extract the directory name (transcript name) transcript="${dir:t}" - + # If the first argument is missing, run all transcripts, otherwise run only transcripts which match a prefix of the argument if [ -z "${1:-}" ] || [[ "$transcript" == "$1"* ]]; then pg_reset_fixtures diff --git a/transcripts/share-apis/history-comments/comment-pull.md b/transcripts/share-apis/history-comments/comment-pull.md new file mode 100644 index 00000000..f50a2a1f --- /dev/null +++ b/transcripts/share-apis/history-comments/comment-pull.md @@ -0,0 +1,4 @@ +```ucm:hide +scratch/main> pull @test/history-comments/main +scratch/main> history +``` diff --git a/transcripts/share-apis/history-comments/prelude.md b/transcripts/share-apis/history-comments/prelude.md new file mode 100644 index 00000000..2ad425cb --- /dev/null +++ b/transcripts/share-apis/history-comments/prelude.md @@ -0,0 +1,18 @@ +```ucm:hide +history-comments/main> builtins.mergeio lib.builtins +``` + +Add some history, then set comments on it. + +```unison:hide +x = 1 +``` + +```ucm +scratch/main> config.set author.name Unison +scratch/main> history.comment /main: "Initial commit with variable x set to 1" +scratch/main> alias.term x y +scratch/main> history.comment /main: "Renamed x to y" +scratch/main> history +scratch/main> push @test/history-comments/main +``` diff --git a/transcripts/share-apis/history-comments/run.zsh b/transcripts/share-apis/history-comments/run.zsh new file mode 100755 index 00000000..fd189a38 --- /dev/null +++ b/transcripts/share-apis/history-comments/run.zsh @@ -0,0 +1,11 @@ +#!/usr/bin/env zsh + +set -e + +source "../../transcript_helpers.sh" + +# Create some history +transcript_ucm transcript prelude.md + +# Pull the history +transcript_ucm transcript comment-pull.md From e9d3451ad0382759957e4b4830edf4a6bafd425f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 15 Jan 2026 14:52:44 -0800 Subject: [PATCH 35/38] Remove redundant constraint --- share-api/src/Share/Web/UCM/HistoryComments/Impl.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs index 7bb919fc..af234168 100644 --- a/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs +++ b/share-api/src/Share/Web/UCM/HistoryComments/Impl.hs @@ -168,7 +168,7 @@ downloadHistoryCommentsStreamImpl mayCallerUserId br@(BranchRef branchRef) conn -- Re-run the given STM action at most n times, collecting the results into a list. -- If the action returns Nothing, stop and return what has been collected so far, along with a Bool indicating whether the action was exhausted. -fetchChunk :: (Show a) => Int -> STM (Maybe a) -> STM ([a], Bool) +fetchChunk :: Int -> STM (Maybe a) -> STM ([a], Bool) fetchChunk size action = do let go 0 = pure ([], False) go n = do From 90eef613cbe1fdcf87875ef6173eb5190fb8930f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 15 Jan 2026 14:54:50 -0800 Subject: [PATCH 36/38] Add comment pull transcripts. Need to update ucm after PRs there are merged --- transcripts/share-apis/history-comments/comment-pull.md | 4 ++-- transcripts/share-apis/history-comments/prelude.md | 3 ++- transcripts/transcript_functions.sh | 2 +- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/transcripts/share-apis/history-comments/comment-pull.md b/transcripts/share-apis/history-comments/comment-pull.md index f50a2a1f..76a4421b 100644 --- a/transcripts/share-apis/history-comments/comment-pull.md +++ b/transcripts/share-apis/history-comments/comment-pull.md @@ -1,4 +1,4 @@ -```ucm:hide -scratch/main> pull @test/history-comments/main +```ucm +scratch/main> pull @transcripts/history-comments/main scratch/main> history ``` diff --git a/transcripts/share-apis/history-comments/prelude.md b/transcripts/share-apis/history-comments/prelude.md index 2ad425cb..225b9f69 100644 --- a/transcripts/share-apis/history-comments/prelude.md +++ b/transcripts/share-apis/history-comments/prelude.md @@ -9,10 +9,11 @@ x = 1 ``` ```ucm +scratch/main> update scratch/main> config.set author.name Unison scratch/main> history.comment /main: "Initial commit with variable x set to 1" scratch/main> alias.term x y scratch/main> history.comment /main: "Renamed x to y" scratch/main> history -scratch/main> push @test/history-comments/main +scratch/main> push @transcripts/history-comments/main ``` diff --git a/transcripts/transcript_functions.sh b/transcripts/transcript_functions.sh index 146c17a2..5b3e4baa 100644 --- a/transcripts/transcript_functions.sh +++ b/transcripts/transcript_functions.sh @@ -11,7 +11,7 @@ mkdir -p "${ucm_xdg_data_dir}/unisonlanguage" ucm_credentials_file="${ucm_xdg_data_dir}/unisonlanguage/credentials.json" # Executable to use when running unison transcripts -export UCM_PATH="${UCM_PATH:-"$(which ucm)"}" +export UCM_PATH="$(which unison-history-comment-message)" export empty_causal_hash='sg60bvjo91fsoo7pkh9gejbn0qgc95vra87ap6l5d35ri0lkaudl7bs12d71sf3fh6p23teemuor7mk1i9n567m50ibakcghjec5ajg' export echo_server_port=9999 export echo_server="http://localhost:${echo_server_port}" From b6b9f915a213a53393e7df0feb6ecfe039ab42f9 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 20 Jan 2026 10:53:14 -0800 Subject: [PATCH 37/38] Rename transcripts --- .../share-apis/history-comments/{prelude.md => comment-push.md} | 0 transcripts/share-apis/history-comments/run.zsh | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) rename transcripts/share-apis/history-comments/{prelude.md => comment-push.md} (100%) diff --git a/transcripts/share-apis/history-comments/prelude.md b/transcripts/share-apis/history-comments/comment-push.md similarity index 100% rename from transcripts/share-apis/history-comments/prelude.md rename to transcripts/share-apis/history-comments/comment-push.md diff --git a/transcripts/share-apis/history-comments/run.zsh b/transcripts/share-apis/history-comments/run.zsh index fd189a38..288bf6d0 100755 --- a/transcripts/share-apis/history-comments/run.zsh +++ b/transcripts/share-apis/history-comments/run.zsh @@ -5,7 +5,7 @@ set -e source "../../transcript_helpers.sh" # Create some history -transcript_ucm transcript prelude.md +transcript_ucm transcript comment-push.md # Pull the history transcript_ucm transcript comment-pull.md From 5ccee7982b9c2938b6b7ec39d9590717c8168509 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 20 Jan 2026 11:14:48 -0800 Subject: [PATCH 38/38] Add transcripts checking history comment push/pull --- .github/workflows/ci.yaml | 5 +- .../history-comments/comment-pull.output.md | 34 ++++++++++ .../history-comments/comment-push.output.md | 63 +++++++++++++++++++ .../share-apis/history-comments/run.zsh | 3 + transcripts/transcript_functions.sh | 2 +- 5 files changed, 105 insertions(+), 2 deletions(-) create mode 100644 transcripts/share-apis/history-comments/comment-pull.output.md create mode 100644 transcripts/share-apis/history-comments/comment-push.output.md diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index a1a4e22f..8ca3f118 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -330,7 +330,10 @@ jobs: # Install ucm mkdir ucm - curl -L https://github.com/unisonweb/unison/releases/download/release%2F1.0.0/ucm-linux-x64.tar.gz | tar -xz -C ucm + + # Use latest trunk build to get comment upload/download support for now. + # Old: https://github.com/unisonweb/unison/releases/download/release%2F1.0.0/ucm-linux-x64.tar.gz + curl -L https://github.com/unisonweb/unison/releases/download/trunk-build/ucm-linux-x64.tar.gz | tar -xz -C ucm export PATH=$PWD/ucm:$PATH # Start share and it's dependencies in the background diff --git a/transcripts/share-apis/history-comments/comment-pull.output.md b/transcripts/share-apis/history-comments/comment-pull.output.md new file mode 100644 index 00000000..6c966691 --- /dev/null +++ b/transcripts/share-apis/history-comments/comment-pull.output.md @@ -0,0 +1,34 @@ +``` ucm +scratch/main> pull @transcripts/history-comments/main + + Updating branch from #sg60bvjo91 to #tjd6qqlhod + + ✅ + + Successfully pulled into scratch/main, which was empty. + +scratch/main> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ Unison + ┃ Renamed x to y + + ⊙ 1. #tjd6qqlhod + + + Adds / updates: + + y + + = Copies: + + Original name New name(s) + x y + + + ⊙ Unison + ┃ Initial commit with variable x set to 1 + + □ 2. #i52j9fd57b (start of history) +``` diff --git a/transcripts/share-apis/history-comments/comment-push.output.md b/transcripts/share-apis/history-comments/comment-push.output.md new file mode 100644 index 00000000..5bdf4a56 --- /dev/null +++ b/transcripts/share-apis/history-comments/comment-push.output.md @@ -0,0 +1,63 @@ +``` ucm :hide +history-comments/main> builtins.mergeio lib.builtins +``` + +Add some history, then set comments on it. + +``` unison :hide +x = 1 +``` + +``` ucm +scratch/main> update + + Done. + +scratch/main> config.set author.name Unison + +scratch/main> history.comment /main: "Initial commit with variable x set to 1" + + Done. + +scratch/main> alias.term x y + + Done. + +scratch/main> history.comment /main: "Renamed x to y" + + Done. + +scratch/main> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ Unison + ┃ Renamed x to y + + ⊙ 1. #tjd6qqlhod + + + Adds / updates: + + y + + = Copies: + + Original name New name(s) + x y + + + ⊙ Unison + ┃ Initial commit with variable x set to 1 + + □ 2. #i52j9fd57b (start of history) + +scratch/main> push @transcripts/history-comments/main + + Uploaded 5 entities. + + I just created @transcripts/history-comments on + http://localhost:5424 + + View it here: @transcripts/history-comments/main on http://localhost:5424 +``` diff --git a/transcripts/share-apis/history-comments/run.zsh b/transcripts/share-apis/history-comments/run.zsh index 288bf6d0..bd19981b 100755 --- a/transcripts/share-apis/history-comments/run.zsh +++ b/transcripts/share-apis/history-comments/run.zsh @@ -4,6 +4,9 @@ set -e source "../../transcript_helpers.sh" +# Currently this must be manually enabled +export UNISON_SYNC_HISTORY_COMMENTS=true + # Create some history transcript_ucm transcript comment-push.md diff --git a/transcripts/transcript_functions.sh b/transcripts/transcript_functions.sh index 5b3e4baa..146c17a2 100644 --- a/transcripts/transcript_functions.sh +++ b/transcripts/transcript_functions.sh @@ -11,7 +11,7 @@ mkdir -p "${ucm_xdg_data_dir}/unisonlanguage" ucm_credentials_file="${ucm_xdg_data_dir}/unisonlanguage/credentials.json" # Executable to use when running unison transcripts -export UCM_PATH="$(which unison-history-comment-message)" +export UCM_PATH="${UCM_PATH:-"$(which ucm)"}" export empty_causal_hash='sg60bvjo91fsoo7pkh9gejbn0qgc95vra87ap6l5d35ri0lkaudl7bs12d71sf3fh6p23teemuor7mk1i9n567m50ibakcghjec5ajg' export echo_server_port=9999 export echo_server="http://localhost:${echo_server_port}"