From 76a1989a0ef72c909795aef0f0f3f1ee8b00eea3 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 15 Oct 2024 11:56:42 -0400
Subject: [PATCH] implement openFileBeingWritten

This bypasses the usual haskell file locking used to prevent opening a
file for read that is being written to.

This is unfortunately a bit of a hack. But it seems fairly unlikely to
get broken by changes to ghc. I hope. Using fdToHandle' will also work.

This does not work on windows because it uses openFd from posix. It
would probably be possible to implement it for windows too, just opening
the FD using the Win32 library instead. However, whether windows will
allow reading from a file that is also being written to I don't know,
and since in the git-annex case the writer could be another process (eg
external special remote), that might be doing its own locking in
windows, that seems a can of worms I'd prefer not to open.
---
 Utility/OpenFile.hs | 32 ++++++++++++++++++++++++++++++++
 git-annex.cabal     |  1 +
 2 files changed, 33 insertions(+)
 create mode 100644 Utility/OpenFile.hs

diff --git a/Utility/OpenFile.hs b/Utility/OpenFile.hs
new file mode 100644
index 0000000000..99ac696039
--- /dev/null
+++ b/Utility/OpenFile.hs
@@ -0,0 +1,32 @@
+{- Opening files
+ -
+ - Copyright 2024 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.OpenFile where
+
+import System.IO
+import System.Posix.IO
+import GHC.IO.FD
+import GHC.IO.Handle.FD
+import GHC.IO.Device
+
+import Utility.OpenFd
+import Utility.RawFilePath
+import Utility.FileSystemEncoding
+
+{- Usually, opening a Handle to a file that another thread also has open
+ - for write is prevented, which avoids a lot of concurrency bugs especially
+ - with lazy IO.
+ - 
+ - However, sometimes one thread is writing and another thread really wants
+ - to read from the same file. This bypasses the usual locking, by claiming
+ - that an opened FD is a Stream.
+ -}
+openFileBeingWritten :: RawFilePath -> IO Handle
+openFileBeingWritten f = do
+	fd <- openFdWithMode f ReadOnly Nothing defaultFileFlags
+	(fd', fdtype) <- mkFD (fromIntegral fd) ReadMode (Just (Stream, 0, 0)) False False
+	mkHandleFromFD fd' fdtype (fromRawFilePath f) ReadMode False Nothing
diff --git a/git-annex.cabal b/git-annex.cabal
index fd3406707a..a771676ff3 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -1091,6 +1091,7 @@ Executable git-annex
     Utility.Network
     Utility.NotificationBroadcaster
     Utility.OpenFd
+    Utility.OpenFile
     Utility.OptParse
     Utility.OSX
     Utility.PID