winio: Set handle offset when opening files in Append mode.

Otherwise we would truncate the file.

7 files changed, 62 insertions, 6 deletions

diff --git a/libraries/base/GHC/IO/Handle/Internals.hs b/libraries/base/GHC/IO/Handle/Internals.hs
index 6aee4bb619..f0a2cdac4b 100644
--- a/libraries/base/GHC/IO/Handle/Internals.hs
+++ b/libraries/base/GHC/IO/Handle/Internals.hs
@@ -63,7 +63,7 @@ import GHC.IO.Buffer
 import GHC.IO.BufferedIO (BufferedIO)
 import GHC.IO.Exception
 import GHC.IO.Device (IODevice, RawIO, SeekMode(..))
-import GHC.IO.SubSystem ((<!>))
+import GHC.IO.SubSystem ((<!>), isWindowsNativeIO)
 import qualified GHC.IO.Device as IODevice
 import qualified GHC.IO.BufferedIO as Buffered
 
@@ -548,6 +548,7 @@ writeCharBuffer h_@Handle__{..} !cbuf = do
     then do
       bbuf'' <- Buffered.flushWriteBuffer haDevice bbuf'
       writeIORef haByteBuffer bbuf''
+      debugIO ("writeCharBuffer after flushing: cbuf=" ++ summaryBuffer bbuf'')
     else
       writeIORef haByteBuffer bbuf'
 
@@ -633,6 +634,18 @@ flushByteReadBuffer h_@Handle__{..} = do
 -- ----------------------------------------------------------------------------
 -- Making Handles
 
+{- Note [Making offsets for append]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  The WINIO subysstem keeps track of offsets for handles
+  on the Haskell side of things instead of letting the OS
+  handle it. This requires us to establish the correct offset
+  for a handle on creation. This is usually zero but slightly
+  more tedious for append modes. There we fall back on IODevice
+  functionality to establish the size of the file and then set
+  the offset accordingly. This is only required for WINIO.
+-}
+
 mkHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev
          -> FilePath
          -> HandleType
@@ -645,8 +658,11 @@ mkHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev
 mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side =
    openTextEncoding mb_codec ha_type $ \ mb_encoder mb_decoder -> do
 
-   let buf_state = initBufferState ha_type
-   bbuf <- Buffered.newBuffer dev buf_state
+   let !buf_state = initBufferState ha_type
+   !bbuf_no_offset <- (Buffered.newBuffer dev buf_state)
+   !buf_offset <- initHandleOffset
+   let !bbuf = bbuf_no_offset { bufOffset = buf_offset}
+
    bbufref <- newIORef bbuf
    last_decode <- newIORef (errorWithoutStackTrace "codec_state", bbuf)
 
@@ -671,6 +687,14 @@ mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side =
                         haOutputNL = outputNL nl,
                         haOtherSide = other_side
                       })
+  where
+    -- See Note [Making offsets for append]
+    initHandleOffset
+      | isAppendHandleType ha_type
+      , isWindowsNativeIO = do
+          size <- IODevice.getSize dev
+          return (fromIntegral size :: Word64)
+      | otherwise = return 0
 
 -- | makes a new 'Handle'
 mkFileHandle :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev)
@@ -826,6 +850,7 @@ hLookAhead_ handle_@Handle__{..} = do
 -- debugging
 
 debugIO :: String -> IO ()
+-- debugIO s = traceEventIO s
 debugIO s
  | c_DEBUG_DUMP
     = do _ <- withCStringLen (s ++ "\n") $
diff --git a/libraries/base/GHC/IO/Handle/Text.hs b/libraries/base/GHC/IO/Handle/Text.hs
index ee0289f066..ab4a2254e3 100644
--- a/libraries/base/GHC/IO/Handle/Text.hs
+++ b/libraries/base/GHC/IO/Handle/Text.hs
@@ -713,8 +713,9 @@ commitBuffer
 commitBuffer hdl !raw !sz !count flush release =
   wantWritableHandle "commitBuffer" hdl $ \h_@Handle__{..} -> do
       debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
-            ++ ", flush=" ++ show flush ++ ", release=" ++ show release)
+            ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++ ", handle=" ++ show hdl)
 
+      -- Offset taken from handle
       writeCharBuffer h_ Buffer{ bufRaw=raw, bufState=WriteBuffer, bufOffset=0,
                                  bufL=0, bufR=count, bufSize=sz }
 
@@ -728,6 +729,8 @@ commitBuffer hdl !raw !sz !count flush release =
                spare_bufs <- readIORef haBuffers
                writeIORef haBuffers (BufferListCons raw spare_bufs)
 
+      -- bb <- readIORef haByteBuffer
+      -- debugIO ("commitBuffer: buffer=" ++ summaryBuffer bb ++ ", handle=" ++ show hdl)
       return ()
 
 -- backwards compatibility; the text package uses this
diff --git a/libraries/base/GHC/IO/Handle/Types.hs b/libraries/base/GHC/IO/Handle/Types.hs
index 71c75d98b1..2ab91e9f09 100644
--- a/libraries/base/GHC/IO/Handle/Types.hs
+++ b/libraries/base/GHC/IO/Handle/Types.hs
@@ -26,6 +26,7 @@ module GHC.IO.Handle.Types (
       BufferList(..),
       HandleType(..),
       isReadableHandleType, isWritableHandleType, isReadWriteHandleType,
+      isAppendHandleType,
       BufferMode(..),
       BufferCodec(..),
       NewlineMode(..), Newline(..), nativeNewline,
@@ -126,6 +127,7 @@ data Handle__
       haByteBuffer  :: !(IORef (Buffer Word8)), -- See [note Buffering Implementation]
       haBufferMode  :: BufferMode,
       haLastDecode  :: !(IORef (dec_state, Buffer Word8)),
+      -- ^ The byte buffer just  before we did our last batch of decoding.
       haCharBuffer  :: !(IORef (Buffer CharBufElem)), -- See [note Buffering Implementation]
       haBuffers     :: !(IORef (BufferList CharBufElem)),  -- spare buffers
       haEncoder     :: Maybe (TextEncoder enc_state),
@@ -170,6 +172,11 @@ isReadWriteHandleType :: HandleType -> Bool
 isReadWriteHandleType ReadWriteHandle{} = True
 isReadWriteHandleType _                 = False
 
+isAppendHandleType :: HandleType -> Bool
+isAppendHandleType AppendHandle = True
+isAppendHandleType _            = False
+
+
 -- INVARIANTS on Handles:
 --
 --   * A handle *always* has a buffer, even if it is only 1 character long
diff --git a/libraries/base/GHC/IO/Handle/Windows.hs b/libraries/base/GHC/IO/Handle/Windows.hs
index e087b50570..b310317bc1 100644
--- a/libraries/base/GHC/IO/Handle/Windows.hs
+++ b/libraries/base/GHC/IO/Handle/Windows.hs
@@ -212,8 +212,7 @@ mkHandleFromHANDLE dev hw_type filepath iomode mb_codec
                 mkDuplexHandle dev filepath mb_codec nl
 
 
-        _other ->
-           mkFileHandle dev filepath iomode mb_codec nl
+        _other -> mkFileHandle dev filepath iomode mb_codec nl
 
 -- | Turn an existing Handle into a Win32 HANDLE. This function throws an
 -- IOError if the Handle does not reference a HANDLE
diff --git a/libraries/base/tests/IO/all.T b/libraries/base/tests/IO/all.T
index 39b7f17134..054b050276 100644
--- a/libraries/base/tests/IO/all.T
+++ b/libraries/base/tests/IO/all.T
@@ -68,6 +68,7 @@ test('openFile005', [], compile_and_run, [''])
 test('openFile006', [], compile_and_run, [''])
 test('openFile007', [], compile_and_run, [''])
 test('openFile008', cmd_prefix('ulimit -n 2048; '), compile_and_run, [''])
+test('openFile009', [], compile_and_run, [''])
 
 test('putStr001',    normal, compile_and_run, [''])
 test('readFile001', [], compile_and_run, [''])
diff --git a/libraries/base/tests/IO/openFile009.hs b/libraries/base/tests/IO/openFile009.hs
new file mode 100644
index 0000000000..00328ed0cb
--- /dev/null
+++ b/libraries/base/tests/IO/openFile009.hs
@@ -0,0 +1,20 @@
+import System.IO
+import System.Cmd
+import System.FilePath
+import Text.Printf
+import System.Directory
+import Control.Monad
+
+testfile = "openFile009_testfile"
+
+-- Make sure opening with append doesn't truncate files.
+main = do
+  h <- openFile testfile Write
+  hPutStr "Hello"
+  hClose h
+  h <- openFile testfile Append
+  hPutStr " World!"
+  hClose h
+  s <- readFile testfile
+  putStrLn s
+
diff --git a/libraries/base/tests/IO/openFile009.stdout b/libraries/base/tests/IO/openFile009.stdout
new file mode 100644
index 0000000000..980a0d5f19
--- /dev/null
+++ b/libraries/base/tests/IO/openFile009.stdout
@@ -0,0 +1 @@
+Hello World!