[WIP] SyncV3

Makefile

@@ -3,7 +3,7 @@
 SHARE_PROJECT_ROOT := $(dir $(abspath $(lastword $(MAKEFILE_LIST))))
 export SHARE_PROJECT_ROOT
 UNAME := $(shell uname)
-STACK_FLAGS := "--fast"
+STACK_FLAGS := --fast
 dist_dir := $(shell stack path | awk '/^dist-dir/{print $$2}')
 exe_name := share-api
 exe := $(dist_dir)/build/$(exe_name)/$(exe_name)

package.yaml

@@ -97,6 +97,7 @@ dependencies:
 - parallel
 - parser-combinators
 - pem
+- profunctors
 - hasql
 - hasql-pool
 - hasql-interpolate
@@ -113,6 +114,7 @@ dependencies:
 - servant-client-core
 - servant-server
 - servant-conduit
+- servant-websockets
 - serialise
 - stm
 - stm-chans
@@ -153,6 +155,7 @@ dependencies:
 - wai-cors
 - wai-extra
 - wai-middleware-prometheus
+- websockets
 - warp
 - witch
 - witherable

share-api.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.37.0.
+-- This file has been generated from package.yaml by hpack version 0.38.1.
 --
 -- see: https://github.com/sol/hpack
 
@@ -196,10 +196,15 @@ library
       Share.Web.UCM.Sync.HashJWT
       Share.Web.UCM.Sync.Impl
       Share.Web.UCM.Sync.Types
+      Share.Web.UCM.SyncCommon.Impl
+      Share.Web.UCM.SyncCommon.Types
       Share.Web.UCM.SyncV2.API
       Share.Web.UCM.SyncV2.Impl
       Share.Web.UCM.SyncV2.Queries
       Share.Web.UCM.SyncV2.Types
+      Share.Web.UCM.SyncV3.API
+      Share.Web.UCM.SyncV3.Impl
+      Share.Web.UCM.SyncV3.Queries
       Share.Web.UI.Links
       Unison.Server.NameSearch.Postgres
       Unison.Server.Share.Definitions
@@ -301,6 +306,7 @@ library
     , parallel
     , parser-combinators
     , pem
+    , profunctors
     , prometheus-client
     , prometheus-metrics-ghc
     , random
@@ -314,6 +320,7 @@ library
     , servant-client-core
     , servant-conduit
     , servant-server
+    , servant-websockets
     , share-auth
     , share-utils
     , stm
@@ -354,6 +361,7 @@ library
     , wai-extra
     , wai-middleware-prometheus
     , warp
+    , websockets
     , witch
     , witherable
     , x509
@@ -458,6 +466,7 @@ executable share-api
     , parallel
     , parser-combinators
     , pem
+    , profunctors
     , prometheus-client
     , prometheus-metrics-ghc
     , random
@@ -471,6 +480,7 @@ executable share-api
     , servant-client-core
     , servant-conduit
     , servant-server
+    , servant-websockets
     , share-api
     , share-auth
     , share-utils
@@ -512,6 +522,7 @@ executable share-api
     , wai-extra
     , wai-middleware-prometheus
     , warp
+    , websockets
     , witch
     , witherable
     , x509

src/Share/Postgres/Orphans.hs

@@ -38,6 +38,7 @@ import Unison.Hash32 qualified as Hash32
 import Unison.Name (Name)
 import Unison.NameSegment.Internal (NameSegment (..))
 import Unison.SyncV2.Types (CBORBytes (..))
+import Unison.SyncV3.Types qualified as SyncV3
 import Unison.Syntax.Name qualified as Name
 import UnliftIO (MonadUnliftIO (..))
 
@@ -286,3 +287,21 @@ instance MonadUnliftIO Hasql.Session where
     case res of
       Left e -> throwError e
       Right a -> pure a
+
+instance Hasql.DecodeValue SyncV3.EntityKind where
+  decodeValue = do
+    Decoders.enum \case
+      "causal" -> Just SyncV3.CausalEntity
+      "namespace" -> Just SyncV3.NamespaceEntity
+      "component" -> Just SyncV3.DefnComponentEntity
+      "patch" -> Just SyncV3.PatchEntity
+      _ -> Nothing
+
+instance Hasql.EncodeValue SyncV3.EntityKind where
+  encodeValue = Encoders.enum \case
+    SyncV3.CausalEntity -> "causal"
+    SyncV3.NamespaceEntity -> "namespace"
+    SyncV3.DefnComponentEntity -> "component"
+    SyncV3.PatchEntity -> "patch"
+
+deriving newtype instance Hasql.DecodeValue SyncV3.EntityDepth

src/Share/Web/API.hs

@@ -17,6 +17,7 @@ import Share.Web.Share.Users.API qualified as Users
 import Share.Web.Support.API qualified as Support
 import Share.Web.Types
 import Share.Web.UCM.SyncV2.API qualified as SyncV2
+import Share.Web.UCM.SyncV3.API qualified as SyncV3
 import Unison.Share.API.Projects qualified as UCMProjects
 import Unison.Sync.API qualified as Unison.Sync
 
@@ -54,6 +55,7 @@ type API =
     :<|> ("ucm" :> "v1" :> "sync" :> MaybeAuthenticatedSession :> Unison.Sync.API)
     :<|> ("ucm" :> "v1" :> "projects" :> MaybeAuthenticatedSession :> UCMProjects.ProjectsAPI)
     :<|> ("ucm" :> "v2" :> "sync" :> MaybeAuthenticatedUserId :> SyncV2.API)
+    :<|> ("ucm" :> "v3" :> "sync" :> MaybeAuthenticatedUserId :> SyncV3.API)
     :<|> ("admin" :> Admin.API)
 
 api :: Proxy API

src/Share/Web/Impl.hs

@@ -29,6 +29,7 @@ import Share.Web.Types
 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
+import Share.Web.UCM.SyncV3.Impl qualified as SyncV3
 import Share.Web.UI.Links qualified as Links
 
 discoveryEndpoint :: WebApp DiscoveryDocument
@@ -90,4 +91,5 @@ server =
     :<|> Sync.server
     :<|> UCMProjects.server
     :<|> SyncV2.server
+    :<|> SyncV3.server
     :<|> Admin.server

src/Share/Web/UCM/SyncCommon/Impl.hs

@@ -0,0 +1,55 @@
+module Share.Web.UCM.SyncCommon.Impl
+  ( parseBranchRef,
+    codebaseForBranchRef,
+  )
+where
+
+import Control.Monad.Except (ExceptT (ExceptT))
+import Servant
+import Share.Codebase qualified as Codebase
+import Share.IDs (ProjectBranchShortHand (..), ProjectReleaseShortHand (..), ProjectShortHand (..))
+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.Project (Project (..))
+import Share.User (User (..))
+import Share.Web.App
+import Share.Web.Authorization qualified as AuthZ
+import Share.Web.UCM.SyncCommon.Types
+import U.Codebase.Sqlite.Orphans ()
+import Unison.SyncV2.Types qualified as SyncV2
+
+parseBranchRef :: SyncV2.BranchRef -> Either Text (Either ProjectReleaseShortHand ProjectBranchShortHand)
+parseBranchRef (SyncV2.BranchRef branchRef) =
+  case parseRelease <|> parseBranch of
+    Just a -> Right a
+    Nothing -> Left $ "Invalid repo info: " <> branchRef
+  where
+    parseBranch :: Maybe (Either ProjectReleaseShortHand ProjectBranchShortHand)
+    parseBranch = fmap Right . eitherToMaybe $ IDs.fromText @ProjectBranchShortHand branchRef
+    parseRelease :: Maybe (Either ProjectReleaseShortHand ProjectBranchShortHand)
+    parseRelease = fmap Left . eitherToMaybe $ IDs.fromText @ProjectReleaseShortHand branchRef
+
+codebaseForBranchRef :: SyncV2.BranchRef -> (ExceptT CodebaseLoadingError WebApp Codebase.CodebaseEnv)
+codebaseForBranchRef branchRef = do
+  case parseBranchRef branchRef of
+    Left err -> throwError (CodebaseLoadingErrorInvalidBranchRef err branchRef)
+    Right (Left (ProjectReleaseShortHand {userHandle, projectSlug})) -> do
+      let projectShortHand = ProjectShortHand {userHandle, projectSlug}
+      (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)
+      let codebaseLoc = Codebase.codebaseLocationForProjectBranchCodebase projectOwnerUserId contributorId
+      pure $ Codebase.codebaseEnv authZToken codebaseLoc
+    Right (Right (ProjectBranchShortHand {userHandle, projectSlug, contributorHandle})) -> do
+      let projectShortHand = ProjectShortHand {userHandle, projectSlug}
+      (Project {ownerUserId = projectOwnerUserId}, contributorId) <- ExceptT . PG.tryRunTransaction $ 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)
+      let codebaseLoc = Codebase.codebaseLocationForProjectBranchCodebase projectOwnerUserId contributorId
+      pure $ Codebase.codebaseEnv authZToken codebaseLoc

src/Share/Web/UCM/SyncCommon/Types.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE DataKinds #-}
+
+module Share.Web.UCM.SyncCommon.Types (CodebaseLoadingError (..)) where
+
+import Data.Text.Encoding qualified as Text
+import Servant
+import Share.IDs
+import Share.IDs qualified as IDs
+import Share.Prelude
+import Share.Utils.Logging qualified as Logging
+import Share.Web.Errors
+import Unison.SyncCommon.Types
+
+data CodebaseLoadingError
+  = CodebaseLoadingErrorProjectNotFound ProjectShortHand
+  | CodebaseLoadingErrorUserNotFound UserHandle
+  | CodebaseLoadingErrorNoReadPermission BranchRef
+  | CodebaseLoadingErrorInvalidBranchRef Text BranchRef
+  deriving stock (Show)
+  deriving (Logging.Loggable) via Logging.ShowLoggable Logging.UserFault CodebaseLoadingError
+
+instance ToServerError CodebaseLoadingError where
+  toServerError = \case
+    CodebaseLoadingErrorProjectNotFound projectShortHand -> (ErrorID "codebase-loading:project-not-found", Servant.err404 {errBody = from . Text.encodeUtf8 $ "Project not found: " <> (IDs.toText projectShortHand)})
+    CodebaseLoadingErrorUserNotFound userHandle -> (ErrorID "codebase-loading:user-not-found", Servant.err404 {errBody = from . Text.encodeUtf8 $ "User not found: " <> (IDs.toText userHandle)})
+    CodebaseLoadingErrorNoReadPermission branchRef -> (ErrorID "codebase-loading:no-read-permission", Servant.err403 {errBody = from . Text.encodeUtf8 $ "No read permission for branch ref: " <> (unBranchRef branchRef)})
+    CodebaseLoadingErrorInvalidBranchRef err branchRef -> (ErrorID "codebase-loading:invalid-branch-ref", Servant.err400 {errBody = from . Text.encodeUtf8 $ "Invalid branch ref: " <> err <> " " <> (unBranchRef branchRef)})

src/Share/Web/UCM/SyncV2/Impl.hs

@@ -7,34 +7,29 @@ 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.Except (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)
+import Share.IDs (UserId)
 import Share.IDs qualified as IDs
 import Share.Postgres qualified as PG
 import Share.Postgres.Causal.Queries qualified as CausalQ
 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
-import Share.Project (Project (..))
-import Share.User (User (..))
 import Share.Utils.Logging qualified as Logging
 import Share.Utils.Unison (hash32ToCausalHash)
 import Share.Web.App
-import Share.Web.Authorization qualified as AuthZ
 import Share.Web.Errors
 import Share.Web.UCM.Sync.HashJWT qualified as HashJWT
+import Share.Web.UCM.SyncCommon.Impl
+import Share.Web.UCM.SyncCommon.Types
 import Share.Web.UCM.SyncV2.Queries qualified as SSQ
 import Share.Web.UCM.SyncV2.Types (IsCausalSpine (..), IsLibRoot (..))
 import U.Codebase.Sqlite.Orphans ()
@@ -58,17 +53,6 @@ server mayUserId =
       causalDependenciesStream = causalDependenciesStreamImpl mayUserId
     }
 
-parseBranchRef :: SyncV2.BranchRef -> Either Text (Either ProjectReleaseShortHand ProjectBranchShortHand)
-parseBranchRef (SyncV2.BranchRef branchRef) =
-  case parseRelease <|> parseBranch of
-    Just a -> Right a
-    Nothing -> Left $ "Invalid repo info: " <> branchRef
-  where
-    parseBranch :: Maybe (Either ProjectReleaseShortHand ProjectBranchShortHand)
-    parseBranch = fmap Right . eitherToMaybe $ IDs.fromText @ProjectBranchShortHand branchRef
-    parseRelease :: Maybe (Either ProjectReleaseShortHand ProjectBranchShortHand)
-    parseRelease = fmap Left . eitherToMaybe $ IDs.fromText @ProjectReleaseShortHand branchRef
-
 downloadEntitiesStreamImpl :: Maybe UserId -> SyncV2.DownloadEntitiesRequest -> WebApp (SourceIO (SyncV2.CBORStream SyncV2.DownloadEntitiesChunk))
 downloadEntitiesStreamImpl mayCallerUserId (SyncV2.DownloadEntitiesRequest {causalHash = causalHashJWT, branchRef, knownHashes}) = do
   either emitErr id <$> runExceptT do
@@ -142,43 +126,6 @@ queueToStream q = do
             loop
   loop
 
-data CodebaseLoadingError
-  = CodebaseLoadingErrorProjectNotFound ProjectShortHand
-  | CodebaseLoadingErrorUserNotFound UserHandle
-  | CodebaseLoadingErrorNoReadPermission SyncV2.BranchRef
-  | CodebaseLoadingErrorInvalidBranchRef Text SyncV2.BranchRef
-  deriving stock (Show)
-  deriving (Logging.Loggable) via Logging.ShowLoggable Logging.UserFault CodebaseLoadingError
-
-instance ToServerError CodebaseLoadingError where
-  toServerError = \case
-    CodebaseLoadingErrorProjectNotFound projectShortHand -> (ErrorID "codebase-loading:project-not-found", Servant.err404 {errBody = from . Text.encodeUtf8 $ "Project not found: " <> (IDs.toText projectShortHand)})
-    CodebaseLoadingErrorUserNotFound userHandle -> (ErrorID "codebase-loading:user-not-found", Servant.err404 {errBody = from . Text.encodeUtf8 $ "User not found: " <> (IDs.toText userHandle)})
-    CodebaseLoadingErrorNoReadPermission branchRef -> (ErrorID "codebase-loading:no-read-permission", Servant.err403 {errBody = from . Text.encodeUtf8 $ "No read permission for branch ref: " <> (SyncV2.unBranchRef branchRef)})
-    CodebaseLoadingErrorInvalidBranchRef err branchRef -> (ErrorID "codebase-loading:invalid-branch-ref", Servant.err400 {errBody = from . Text.encodeUtf8 $ "Invalid branch ref: " <> err <> " " <> (SyncV2.unBranchRef branchRef)})
-
-codebaseForBranchRef :: SyncV2.BranchRef -> (ExceptT CodebaseLoadingError WebApp Codebase.CodebaseEnv)
-codebaseForBranchRef branchRef = do
-  case parseBranchRef branchRef of
-    Left err -> throwError (CodebaseLoadingErrorInvalidBranchRef err branchRef)
-    Right (Left (ProjectReleaseShortHand {userHandle, projectSlug})) -> do
-      let projectShortHand = ProjectShortHand {userHandle, projectSlug}
-      (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)
-      let codebaseLoc = Codebase.codebaseLocationForProjectBranchCodebase projectOwnerUserId contributorId
-      pure $ Codebase.codebaseEnv authZToken codebaseLoc
-    Right (Right (ProjectBranchShortHand {userHandle, projectSlug, contributorHandle})) -> do
-      let projectShortHand = ProjectShortHand {userHandle, projectSlug}
-      (Project {ownerUserId = projectOwnerUserId}, contributorId) <- ExceptT . PG.tryRunTransaction $ 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)
-      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

src/Share/Web/UCM/SyncV3/API.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Share.Web.UCM.SyncV3.API
+  ( API,
+    Routes (..),
+  )
+where
+
+import GHC.Generics (Generic)
+import Servant
+import Servant.API.WebSocket (WebSocket)
+
+data Routes mode = Routes
+  { downloadEntities :: mode :- "download" :> DownloadEntitiesEndpoint
+  }
+  deriving stock (Generic)
+
+type API = NamedRoutes Routes
+
+type DownloadEntitiesEndpoint = WebSocket