From 65f7fdd1dfe9359935b37e48242af85b49510c55 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 3 Nov 2025 16:14:55 -0800 Subject: [PATCH 1/4] Make transcript output writing atomic --- unison-cli/transcripts/Transcripts.hs | 66 +++++++++++++++------------ 1 file changed, 36 insertions(+), 30 deletions(-) diff --git a/unison-cli/transcripts/Transcripts.hs b/unison-cli/transcripts/Transcripts.hs index 28121783e2..7984f51948 100644 --- a/unison-cli/transcripts/Transcripts.hs +++ b/unison-cli/transcripts/Transcripts.hs @@ -67,39 +67,45 @@ testBuilder expectFailure replaceOriginal recordFailure inputDir outputDir prelu transcriptSrc <- BS.readFile $ inputDir filePath out <- silence $ runTranscript filePath transcriptSrc codebase pure (filePath, out) + let writeOutput outputFile action = withSystemTempFile "transcript-output" \fp outputHandle -> + hClose outputHandle + action fp + renameFile fp outputFile for_ outputs \case (filePath, Left err) -> do - let outputFile = outputDir outputFileForTranscript filePath - case err of - Transcript.PortBindingFailure -> do - let errMsg = "Failed to bind codebase server to the default port when running transcripts in " <> filePath - io . writeUtf8 outputFile $ Text.pack errMsg - when (not expectFailure) $ do - io $ recordFailure (inputDir filePath, Text.pack errMsg) - crash errMsg - Transcript.ParseError errors -> do - let bundle = MP.errorBundlePretty errors - errMsg = "Error parsing " <> filePath <> ": " <> bundle - -- Drop the file name, to avoid POSIX/Windows conflicts - io . writeUtf8 outputFile . Text.dropWhile (/= ':') $ Text.pack bundle - when (not expectFailure) $ do - io $ recordFailure (inputDir filePath, Text.pack errMsg) - crash errMsg - Transcript.RunFailure errOutput -> do - let errText = Transcript.format errOutput - io $ writeUtf8 outputFile errText - when (not expectFailure) $ do - io $ Text.putStrLn errText - io $ recordFailure (inputDir filePath, errText) - crash $ "Failure in " <> filePath + let actualOutputFile = outputDir outputFileForTranscript filePath + withOutput actualOutputFile \outputFile -> do + case err of + Transcript.PortBindingFailure -> do + let errMsg = "Failed to bind codebase server to the default port when running transcripts in " <> filePath + io . writeUtf8 outputFile $ Text.pack errMsg + when (not expectFailure) $ do + io $ recordFailure (inputDir filePath, Text.pack errMsg) + crash errMsg + Transcript.ParseError errors -> do + let bundle = MP.errorBundlePretty errors + errMsg = "Error parsing " <> filePath <> ": " <> bundle + -- Drop the file name, to avoid POSIX/Windows conflicts + io . writeUtf8 outputFile . Text.dropWhile (/= ':') $ Text.pack bundle + when (not expectFailure) $ do + io $ recordFailure (inputDir filePath, Text.pack errMsg) + crash errMsg + Transcript.RunFailure errOutput -> do + let errText = Transcript.format errOutput + io $ writeUtf8 outputFile errText + when (not expectFailure) $ do + io $ Text.putStrLn errText + io $ recordFailure (inputDir filePath, errText) + crash $ "Failure in " <> filePath (filePath, Right out) -> do - let outputFile = outputDir if replaceOriginal then filePath else outputFileForTranscript filePath - io . createDirectoryIfMissing True $ takeDirectory outputFile - io . writeUtf8 outputFile $ Transcript.format out - when expectFailure $ do - let errMsg = "Expected a failure, but transcript was successful." - io $ recordFailure (filePath, Text.pack errMsg) - crash errMsg + let actualOutputFile = outputDir if replaceOriginal then filePath else outputFileForTranscript filePath + withOutput actualOutputFile \outputFile -> do + io . createDirectoryIfMissing True $ takeDirectory outputFile + io . writeUtf8 outputFile $ Transcript.format out + when expectFailure $ do + let errMsg = "Expected a failure, but transcript was successful." + io $ recordFailure (filePath, Text.pack errMsg) + crash errMsg ok where files = prelude ++ [transcript] From f0b0f38c2039e62f0f70c54b5a0afe4552d8f1ad Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 4 Nov 2025 14:34:00 -0800 Subject: [PATCH 2/4] Add atomicallyReplaceFile to prelude --- lib/unison-prelude/src/Unison/Prelude.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index ef48bc2556..74d05439ef 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -5,6 +5,7 @@ module Unison.Prelude safeReadUtf8StdIn, writeUtf8, prependUtf8, + atomicallyReplaceFile, uncurry4, reportBug, tShow, @@ -100,6 +101,8 @@ import Text.Read as X (readMaybe) import UnliftIO as X (MonadUnliftIO (..), askRunInIO, askUnliftIO, try, withUnliftIO) import UnliftIO qualified import UnliftIO.Directory qualified as UnliftIO +import UnliftIO.IO (hClose) +import UnliftIO.Temporary (withSystemTempFile) import Witch as X (From (from), TryFrom (tryFrom), TryFromException (TryFromException), into, tryInto) import Witherable as X (filterA, forMaybe, mapMaybe, wither, witherMap) @@ -251,6 +254,16 @@ writeUtf8 fileName txt = do Handle.hSetEncoding handle IO.utf8 Text.hPutStr handle txt +-- | Atomically replace the contents of a file with some text +-- Unfortunately this _still_ isn't atomic on Windows; but is still +-- less likely to leave an empty file than writing directly to the output file. +atomicallyReplaceFile :: (MonadIO m) => FilePath -> Text -> m () +atomicallyReplaceFile path txt = liftIO $ do + withSystemTempFile "temp" \fp outputHandle -> do + hClose outputHandle + liftIO $ writeUtf8 fp txt + UnliftIO.renameFile fp path + -- | Atomically prepend some text to a file, creating the file if it doesn't already exist prependUtf8 :: FilePath -> Text -> IO () prependUtf8 path txt = do From bb91a9cac9255060d7ccbeee69cbd01274d4afdb Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 4 Nov 2025 14:34:00 -0800 Subject: [PATCH 3/4] Make transcript file output writing atomic --- unison-cli/package.yaml | 1 - unison-cli/transcripts/Transcripts.hs | 75 ++++++++++++++------------- unison-cli/unison-cli.cabal | 3 +- 3 files changed, 39 insertions(+), 40 deletions(-) diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 6257834e98..f0832c8f77 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -153,7 +153,6 @@ executables: - base - bytestring - code-page - - directory - easytest - filepath - megaparsec diff --git a/unison-cli/transcripts/Transcripts.hs b/unison-cli/transcripts/Transcripts.hs index 7984f51948..401d27eb7b 100644 --- a/unison-cli/transcripts/Transcripts.hs +++ b/unison-cli/transcripts/Transcripts.hs @@ -11,7 +11,6 @@ import Data.List import Data.Text qualified as Text import Data.Text.IO qualified as Text import EasyTest -import System.Directory import System.Environment (getArgs) import System.FilePath ( replaceExtension, @@ -30,7 +29,15 @@ import Unison.Codebase.Transcript.Runner as Transcript import Unison.Codebase.Verbosity qualified as Verbosity import Unison.Prelude import Unison.Util.Timing +import UnliftIO (hClose) +import UnliftIO.Directory + ( createDirectoryIfMissing, + listDirectory, + renameDirectory, + renameFile, + ) import UnliftIO.STM qualified as STM +import UnliftIO.Temporary (withSystemTempFile) data TestConfig = TestConfig { matchPrefix :: Maybe String @@ -67,45 +74,39 @@ testBuilder expectFailure replaceOriginal recordFailure inputDir outputDir prelu transcriptSrc <- BS.readFile $ inputDir filePath out <- silence $ runTranscript filePath transcriptSrc codebase pure (filePath, out) - let writeOutput outputFile action = withSystemTempFile "transcript-output" \fp outputHandle -> - hClose outputHandle - action fp - renameFile fp outputFile for_ outputs \case (filePath, Left err) -> do - let actualOutputFile = outputDir outputFileForTranscript filePath - withOutput actualOutputFile \outputFile -> do - case err of - Transcript.PortBindingFailure -> do - let errMsg = "Failed to bind codebase server to the default port when running transcripts in " <> filePath - io . writeUtf8 outputFile $ Text.pack errMsg - when (not expectFailure) $ do - io $ recordFailure (inputDir filePath, Text.pack errMsg) - crash errMsg - Transcript.ParseError errors -> do - let bundle = MP.errorBundlePretty errors - errMsg = "Error parsing " <> filePath <> ": " <> bundle - -- Drop the file name, to avoid POSIX/Windows conflicts - io . writeUtf8 outputFile . Text.dropWhile (/= ':') $ Text.pack bundle - when (not expectFailure) $ do - io $ recordFailure (inputDir filePath, Text.pack errMsg) - crash errMsg - Transcript.RunFailure errOutput -> do - let errText = Transcript.format errOutput - io $ writeUtf8 outputFile errText - when (not expectFailure) $ do - io $ Text.putStrLn errText - io $ recordFailure (inputDir filePath, errText) - crash $ "Failure in " <> filePath + let outputFile = outputDir outputFileForTranscript filePath + case err of + Transcript.PortBindingFailure -> do + let errMsg = "Failed to bind codebase server to the default port when running transcripts in " <> filePath + atomicallyReplaceFile outputFile $ Text.pack errMsg + when (not expectFailure) $ do + io $ recordFailure (inputDir filePath, Text.pack errMsg) + crash errMsg + Transcript.ParseError errors -> do + let bundle = MP.errorBundlePretty errors + errMsg = "Error parsing " <> filePath <> ": " <> bundle + -- Drop the file name, to avoid POSIX/Windows conflicts + atomicallyReplaceFile outputFile . Text.dropWhile (/= ':') $ Text.pack bundle + when (not expectFailure) $ do + io $ recordFailure (inputDir filePath, Text.pack errMsg) + crash errMsg + Transcript.RunFailure errOutput -> do + let errText = Transcript.format errOutput + atomicallyReplaceFile outputFile errText + when (not expectFailure) $ do + io $ Text.putStrLn errText + io $ recordFailure (inputDir filePath, errText) + crash $ "Failure in " <> filePath (filePath, Right out) -> do - let actualOutputFile = outputDir if replaceOriginal then filePath else outputFileForTranscript filePath - withOutput actualOutputFile \outputFile -> do - io . createDirectoryIfMissing True $ takeDirectory outputFile - io . writeUtf8 outputFile $ Transcript.format out - when expectFailure $ do - let errMsg = "Expected a failure, but transcript was successful." - io $ recordFailure (filePath, Text.pack errMsg) - crash errMsg + let outputFile = outputDir if replaceOriginal then filePath else outputFileForTranscript filePath + io . createDirectoryIfMissing True $ takeDirectory outputFile + atomicallyReplaceFile outputFile $ Transcript.format out + when expectFailure $ do + let errMsg = "Expected a failure, but transcript was successful." + io $ recordFailure (filePath, Text.pack errMsg) + crash errMsg ok where files = prelude ++ [transcript] diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 1de4ab84bb..4c5a92d2aa 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack @@ -359,7 +359,6 @@ executable transcripts base , bytestring , code-page - , directory , easytest , filepath , megaparsec From 53d4292142a6efce3b74dc38f5add5cbe2abef6f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 4 Nov 2025 15:14:25 -0800 Subject: [PATCH 4/4] Fix transcripts imports --- unison-cli/transcripts/Transcripts.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/unison-cli/transcripts/Transcripts.hs b/unison-cli/transcripts/Transcripts.hs index 401d27eb7b..74e2bba13c 100644 --- a/unison-cli/transcripts/Transcripts.hs +++ b/unison-cli/transcripts/Transcripts.hs @@ -29,15 +29,12 @@ import Unison.Codebase.Transcript.Runner as Transcript import Unison.Codebase.Verbosity qualified as Verbosity import Unison.Prelude import Unison.Util.Timing -import UnliftIO (hClose) import UnliftIO.Directory ( createDirectoryIfMissing, listDirectory, renameDirectory, - renameFile, ) import UnliftIO.STM qualified as STM -import UnliftIO.Temporary (withSystemTempFile) data TestConfig = TestConfig { matchPrefix :: Maybe String