⅄ trunk → 25-02-04-fix-4536

codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs

@@ -3839,8 +3839,8 @@ insertProjectBranch description causalHashId (ProjectBranch projectId branchId b
 
   execute
     [sql|
-      INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id)
-        VALUES (:projectId, :branchId, :branchName, :causalHashId)
+      INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id, last_accessed)
+        VALUES (:projectId, :branchId, :branchName, :causalHashId, strftime('%s', 'now', 'subsec'))
     |]
   whenJust maybeParentBranchId \parentBranchId ->
     execute
@@ -4478,7 +4478,7 @@ setCurrentProjectPath projId branchId path = do
   execute
     [sql|
       UPDATE project_branch
-      SET last_accessed = strftime('%s', 'now')
+      SET last_accessed = strftime('%s', 'now', 'subsec')
       WHERE project_id = :projId
         AND branch_id = :branchId
     |]

docs/configuration.md

@@ -10,14 +10,15 @@
     * [`UNISON_SHARE_ACCESS_TOKEN`](#unison_share_access_token)
     * [`UNISON_READONLY`](#unison_readonly)
     * [`UNISON_ENTITY_VALIDATION`](#unison_entity_validation)
+    * [`UNISON_SYNC_VERSION`](#unison_sync_version)
     * [Local Codebase Server](#local-codebase-server)
 * [Codebase Configuration](#codebase-configuration)
 
 ## UCM Configuration
 
 ### `UNISON_DEBUG`
 
-Enable debugging output for various portions of the application. 
+Enable debugging output for various portions of the application.
 See `lib/unison-prelude/src/Unison/Debug.hs` for the full list of supported flags.
 
 E.g.
@@ -62,7 +63,7 @@ Note for Windows users: Due to an outstanding issue with GHC's IO manager on Win
 Enabling the LSP on windows can cause UCM to hang on exit and may require the process to be killed by the operating system or via Ctrl-C.
 Note that this doesn't pose any risk of codebase corruption or cause any known issues, it's simply an annoyance.
 
-If you accept this annoyance, you can enable the LSP server on Windows by exporting the `UNISON_LSP_ENABLED=true` environment variable. 
+If you accept this annoyance, you can enable the LSP server on Windows by exporting the `UNISON_LSP_ENABLED=true` environment variable.
 
 You can set this persistently in powershell using:
 
@@ -117,6 +118,14 @@ Defaults to enabled.
 $ UNISON_ENTITY_VALIDATION="false" ucm
 ```
 
+### `UNISON_SYNC_VERSION`
+
+Allows enabling the experimental Sync Version 2 protocol when downloading code from Share.
+
+```sh
+$ UNISON_ENTITY_VALIDATION="2" ucm
+```
+
 ### `UNISON_PULL_WORKERS`
 
 Allows setting the number of workers to use when pulling from a codebase server.

lib/unison-prelude/src/Unison/Prelude.hs

@@ -25,6 +25,7 @@ module Unison.Prelude
     whenJustM,
     eitherToMaybe,
     maybeToEither,
+    eitherToThese,
     altSum,
     altMap,
     hoistMaybe,
@@ -82,6 +83,7 @@ import Data.Text as X (Text)
 import Data.Text qualified as Text
 import Data.Text.Encoding as X (decodeUtf8, encodeUtf8)
 import Data.Text.IO qualified as Text
+import Data.These (These (..))
 import Data.Traversable as X (for)
 import Data.Typeable as X (Typeable)
 import Data.Void as X (Void)
@@ -205,6 +207,9 @@ throwEitherM = throwEitherMWith id
 throwEitherMWith :: forall e e' m a. (MonadIO m, Exception e') => (e -> e') -> m (Either e a) -> m a
 throwEitherMWith f action = throwExceptT . withExceptT f $ (ExceptT action)
 
+eitherToThese :: Either a b -> These a b
+eitherToThese = either This That
+
 tShow :: (Show a) => a -> Text
 tShow = Text.pack . show
 

lib/unison-prelude/src/Unison/Util/Set.hs

@@ -5,6 +5,7 @@ module Unison.Util.Set
     mapMaybe,
     symmetricDifference,
     Unison.Util.Set.traverse,
+    Unison.Util.Set.for,
     flatMap,
     filterM,
     forMaybe,
@@ -51,6 +52,9 @@ forMaybe xs f =
 traverse :: (Applicative f, Ord b) => (a -> f b) -> Set a -> f (Set b)
 traverse f = fmap Set.fromList . Prelude.traverse f . Set.toList
 
+for :: (Ord b, Applicative f) => Set a -> (a -> f b) -> f (Set b)
+for = flip Unison.Util.Set.traverse
+
 flatMap :: (Ord b) => (a -> Set b) -> Set a -> Set b
 flatMap f = Set.unions . fmap f . Set.toList
 

lib/unison-sqlite/package.yaml

@@ -9,6 +9,7 @@ library:
 
   dependencies:
     - base
+    - containers
     - direct-sqlite
     - megaparsec
     - pretty-simple

lib/unison-sqlite/src/Unison/Sqlite/Connection.hs

@@ -58,6 +58,7 @@ module Unison.Sqlite.Connection
   )
 where
 
+import Data.Map qualified as Map
 import Database.SQLite.Simple qualified as Sqlite
 import Database.SQLite.Simple.FromField qualified as Sqlite
 import Database.SQLite3 qualified as Direct.Sqlite
@@ -71,7 +72,10 @@ import Unison.Sqlite.Connection.Internal (Connection (..))
 import Unison.Sqlite.Exception
 import Unison.Sqlite.Sql (Sql (..))
 import Unison.Sqlite.Sql qualified as Sql
+import UnliftIO (atomically)
 import UnliftIO.Exception
+import UnliftIO.STM (readTVar)
+import UnliftIO.STM qualified as STM
 
 -- | Perform an action with a connection to a SQLite database.
 --
@@ -103,19 +107,47 @@ openConnection name file = do
       Just "" -> file
       _ -> "file:" <> file <> "?mode=ro"
   conn0 <- Sqlite.open sqliteURI `catch` rethrowAsSqliteConnectException name file
-  let conn = Connection {conn = conn0, file, name}
+  statementCache <- STM.newTVarIO Map.empty
+  let conn = Connection {conn = conn0, file, name, statementCache}
   execute conn [Sql.sql| PRAGMA foreign_keys = ON |]
   execute conn [Sql.sql| PRAGMA busy_timeout = 60000 |]
+  execute conn [Sql.sql| PRAGMA synchronous = normal |]
+  execute conn [Sql.sql| PRAGMA journal_size_limit = 6144000 |]
+  execute conn [Sql.sql| PRAGMA cache_size = -64000 |]
+  execute conn [Sql.sql| PRAGMA temp_store = 2 |]
+
   pure conn
 
 -- Close a connection opened with 'openConnection'.
 closeConnection :: Connection -> IO ()
-closeConnection (Connection _ _ conn) =
+closeConnection conn@(Connection {conn = conn0}) = do
   -- FIXME if this throws an exception, it won't be under `SomeSqliteException`
   -- Possible fixes:
   --   1. Add close exception to the hierarchy, e.g. `SqliteCloseException`
   --   2. Always ignore exceptions thrown by `close` (Mitchell prefers this one)
-  Sqlite.close conn
+  closeAllStatements conn
+  Sqlite.close conn0
+
+withStatement :: Connection -> Text -> (Sqlite.Statement -> IO a) -> IO a
+withStatement conn sql action = do
+  bracket (prepareStatement conn sql) Sqlite.reset action
+  where
+    prepareStatement :: Connection -> Text -> IO Sqlite.Statement
+    prepareStatement Connection {conn, statementCache} sql = do
+      cached <- atomically $ do
+        cache <- STM.readTVar statementCache
+        pure $ Map.lookup sql cache
+      case cached of
+        Just stmt -> pure stmt
+        Nothing -> do
+          stmt <- Sqlite.openStatement conn (coerce @Text @Sqlite.Query sql)
+          atomically $ STM.modifyTVar statementCache (Map.insert sql stmt)
+          pure stmt
+
+closeAllStatements :: Connection -> IO ()
+closeAllStatements Connection {statementCache} = do
+  cache <- atomically $ readTVar statementCache
+  for_ cache Sqlite.closeStatement
 
 -- An internal type, for making prettier debug logs
 
@@ -152,7 +184,7 @@ logQuery (Sql sql params) result =
 -- Without results
 
 execute :: (HasCallStack) => Connection -> Sql -> IO ()
-execute conn@(Connection _ _ conn0) sql@(Sql s params) = do
+execute conn sql@(Sql s params) = do
   logQuery sql Nothing
   doExecute `catch` \(exception :: Sqlite.SQLError) ->
     throwSqliteQueryException
@@ -163,16 +195,16 @@ execute conn@(Connection _ _ conn0) sql@(Sql s params) = do
         }
   where
     doExecute :: IO ()
-    doExecute =
-      Sqlite.withStatement conn0 (coerce s) \(Sqlite.Statement statement) -> do
-        bindParameters statement params
-        void (Direct.Sqlite.step statement)
+    doExecute = do
+      withStatement conn s \statement -> do
+        bindParameters (coerce statement) params
+        void (Direct.Sqlite.step $ coerce statement)
 
 -- | Execute one or more semicolon-delimited statements.
 --
 -- This function does not support parameters, and is mostly useful for executing DDL and migrations.
 executeStatements :: (HasCallStack) => Connection -> Text -> IO ()
-executeStatements conn@(Connection _ _ (Sqlite.Connection database _tempNameCounter)) sql = do
+executeStatements conn@(Connection {conn = Sqlite.Connection database _tempNameCounter}) sql = do
   logQuery (Sql sql []) Nothing
   Direct.Sqlite.exec database sql `catch` \(exception :: Sqlite.SQLError) ->
     throwSqliteQueryException
@@ -185,7 +217,7 @@ executeStatements conn@(Connection _ _ (Sqlite.Connection database _tempNameCoun
 -- With results, without checks
 
 queryStreamRow :: (HasCallStack, Sqlite.FromRow a) => Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r
-queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback =
+queryStreamRow conn sql@(Sql s params) callback =
   run `catch` \(exception :: Sqlite.SQLError) ->
     throwSqliteQueryException
       SqliteQueryExceptionInfo
@@ -194,8 +226,8 @@ queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback =
           sql
         }
   where
-    run =
-      bracket (Sqlite.openStatement conn0 (coerce s)) Sqlite.closeStatement \statement -> do
+    run = do
+      withStatement conn s \statement -> do
         Sqlite.bind statement params
         callback (Sqlite.nextRow statement)
 
@@ -213,7 +245,7 @@ queryStreamCol =
     queryStreamRow
 
 queryListRow :: forall a. (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO [a]
-queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do
+queryListRow conn sql@(Sql s params) = do
   result <-
     doQuery
       `catch` \(exception :: Sqlite.SQLError) ->
@@ -228,7 +260,7 @@ queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do
   where
     doQuery :: IO [a]
     doQuery =
-      Sqlite.withStatement conn0 (coerce s) \statement -> do
+      withStatement conn (coerce s) \statement -> do
         bindParameters (coerce statement) params
         let loop :: [a] -> IO [a]
             loop rows =
@@ -347,7 +379,7 @@ queryOneColCheck conn s check =
 -- Rows modified
 
 rowsModified :: Connection -> IO Int
-rowsModified (Connection _ _ conn) =
+rowsModified (Connection {conn}) =
   Sqlite.changes conn
 
 -- Vacuum

lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs

@@ -3,15 +3,19 @@ module Unison.Sqlite.Connection.Internal
   )
 where
 
+import Data.Map (Map)
+import Data.Text (Text)
 import Database.SQLite.Simple qualified as Sqlite
+import UnliftIO.STM (TVar)
 
 -- | A /non-thread safe/ connection to a SQLite database.
 data Connection = Connection
   { name :: String,
     file :: FilePath,
-    conn :: Sqlite.Connection
+    conn :: Sqlite.Connection,
+    statementCache :: TVar (Map Text Sqlite.Statement)
   }
 
 instance Show Connection where
-  show (Connection name file _conn) =
+  show (Connection name file _conn _statementCache) =
     "Connection { name = " ++ show name ++ ", file = " ++ show file ++ " }"

lib/unison-sqlite/unison-sqlite.cabal

@@ -65,6 +65,7 @@ library
   ghc-options: -Wall
   build-depends:
       base
+    , containers
     , direct-sqlite
     , megaparsec
     , pretty-simple

unison-cli/src/Unison/Cli/DownloadUtils.hs

@@ -4,13 +4,15 @@
 module Unison.Cli.DownloadUtils
   ( downloadProjectBranchFromShare,
     downloadLooseCodeFromShare,
+    SyncVersion (..),
   )
 where
 
 import Control.Concurrent.STM (atomically)
 import Control.Concurrent.STM.TVar (modifyTVar', newTVarIO, readTVar, readTVarIO)
 import Data.List.NonEmpty (pattern (:|))
 import System.Console.Regions qualified as Console.Regions
+import System.IO.Unsafe (unsafePerformIO)
 import U.Codebase.HashTags (CausalHash)
 import U.Codebase.Sqlite.Queries qualified as Queries
 import Unison.Cli.Monad (Cli)
@@ -28,9 +30,23 @@ import Unison.Share.API.Hash qualified as Share
 import Unison.Share.Codeserver qualified as Codeserver
 import Unison.Share.Sync qualified as Share
 import Unison.Share.Sync.Types qualified as Share
+import Unison.Share.SyncV2 qualified as SyncV2
 import Unison.Share.Types (codeserverBaseURL)
 import Unison.Sync.Common qualified as Sync.Common
 import Unison.Sync.Types qualified as Share
+import Unison.SyncV2.Types qualified as SyncV2
+import UnliftIO.Environment qualified as UnliftIO
+
+data SyncVersion = SyncV1 | SyncV2
+  deriving (Eq, Show)
+
+-- | The version of the sync protocol to use.
+syncVersion :: SyncVersion
+syncVersion = unsafePerformIO do
+  UnliftIO.lookupEnv "UNISON_SYNC_VERSION"
+    <&> \case
+      Just "2" -> SyncV2
+      _ -> SyncV1
 
 -- | Download a project/branch from Share.
 downloadProjectBranchFromShare ::
@@ -41,24 +57,34 @@ downloadProjectBranchFromShare ::
 downloadProjectBranchFromShare useSquashed branch =
   Cli.labelE \done -> do
     let remoteProjectBranchName = branch.branchName
-    let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName))
     causalHashJwt <-
       case (useSquashed, branch.squashedBranchHead) of
         (Share.IncludeSquashedHead, Nothing) -> done Output.ShareExpectedSquashedHead
         (Share.IncludeSquashedHead, Just squashedHead) -> pure squashedHead
         (Share.NoSquashedHead, _) -> pure branch.branchHead
     exists <- Cli.runTransaction (Queries.causalExistsByHash32 (Share.hashJWTHash causalHashJwt))
     when (not exists) do
-      (result, numDownloaded) <-
-        Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do
-          result <- Share.downloadEntities Share.hardCodedBaseUrl repoInfo causalHashJwt downloadedCallback
-          numDownloaded <- liftIO getNumDownloaded
-          pure (result, numDownloaded)
-      result & onLeft \err0 -> do
-        done case err0 of
-          Share.SyncError err -> Output.ShareErrorDownloadEntities err
-          Share.TransportError err -> Output.ShareErrorTransport err
-      Cli.respond (Output.DownloadedEntities numDownloaded)
+      case syncVersion of
+        SyncV1 -> do
+          let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName))
+          Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do
+            result <- Share.downloadEntities Share.hardCodedBaseUrl repoInfo causalHashJwt downloadedCallback
+            numDownloaded <- liftIO getNumDownloaded
+            result & onLeft \err0 -> do
+              done case err0 of
+                Share.SyncError err -> Output.ShareErrorDownloadEntities err
+                Share.TransportError err -> Output.ShareErrorTransport err
+            Cli.respond (Output.DownloadedEntities numDownloaded)
+        SyncV2 -> do
+          let branchRef = SyncV2.BranchRef (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName))
+          let downloadedCallback = \_ -> pure ()
+          let shouldValidate = not $ Codeserver.isCustomCodeserver Codeserver.defaultCodeserver
+          result <- SyncV2.syncFromCodeserver shouldValidate Share.hardCodedBaseUrl branchRef causalHashJwt downloadedCallback
+          result & onLeft \err0 -> do
+            done case err0 of
+              Share.SyncError pullErr ->
+                Output.ShareErrorPullV2 pullErr
+              Share.TransportError err -> Output.ShareErrorTransport err
     pure (Sync.Common.hash32ToCausalHash (Share.hashJWTHash causalHashJwt))
 
 -- | Download loose code from Share.