Add long path support wrt #39

Author: hasufell

file-io.cabal

@@ -29,6 +29,11 @@ flag os-string
   default: False
   manual: False
 
+flag long-paths
+  description: Enable a hack for ad-hoc long path support on Windows
+  default: True
+  manual: True
+
 library
   default-language: Haskell2010
 
@@ -51,6 +56,9 @@ library
   else
     build-depends: filepath >= 1.4.100.0 && < 1.5.0.0
 
+  if flag(long-paths)
+    cpp-options:   -DLONG_PATHS
+
   exposed-modules:
     System.File.OsPath
     System.File.OsPath.Internal
@@ -111,6 +119,8 @@ test-suite Properties
     main-is: Properties.hs
     type: exitcode-stdio-1.0
     default-language: Haskell2010
-    build-depends: base >=4.13.0.0 && <5, bytestring, tasty, tasty-hunit, file-io, filepath, temporary
+    build-depends: base >=4.13.0.0 && <5, bytestring, directory, tasty, tasty-hunit, file-io, filepath, temporary
     ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N10"
+    if flag(long-paths)
+      cpp-options:   -DLONG_PATHS
 

tests/Properties.hs

@@ -18,12 +18,21 @@ import GHC.IO.Exception (IOErrorType(..), IOException(..))
 import System.IO
 import System.IO.Temp
 import qualified Data.ByteString as BS
+#if defined(LONG_PATHS)
+import Control.Monad (when)
+import System.Directory.OsPath (createDirectory, makeAbsolute)
+import System.IO.Error (catchIOError)
+#endif
 
 
 main :: IO ()
 main = defaultMain $ testGroup "All"
     [ testGroup "System.File.OsPath"
-       [ testCase "readFile . writeFile" writeFileReadFile
+       [
+#if defined(LONG_PATHS)
+         testCase "writeFile (very long path)" writeFileLongPath,
+#endif
+         testCase "readFile . writeFile" writeFileReadFile
        , testCase "readFile . writeFile  . writeFile" writeWriteFileReadFile
        , testCase "readFile . appendFile . writeFile" appendFileReadFile
        , testCase "iomode: ReadFile does not allow write" iomodeReadFile
@@ -56,6 +65,29 @@ main = defaultMain $ testGroup "All"
        ]
     ]
 
+#if defined(LONG_PATHS)
+writeFileLongPath :: Assertion
+writeFileLongPath = do
+  withSystemTempDirectory "test" $ \baseDir' -> do
+    baseDir <- OSP.encodeFS baseDir'
+    let longName = mconcat (replicate 10 [osp|foo|])
+    let longDir = baseDir </> longName </> longName
+
+    supportsLongPaths <- do
+        -- create 2 dirs because 1 path segment by itself can't exceed MAX_PATH
+        -- tests: [createDirectory]
+        createDirectory =<< makeAbsolute longName
+        createDirectory longDir
+        return True
+      `catchIOError` \ _ ->
+        return False
+
+    when supportsLongPaths $ do
+      OSP.writeFile (longDir </> [osp|foo|]) "test"
+      contents <- OSP.readFile (longDir </> [osp|foo|])
+      "test" @=? contents
+#endif
+
 writeFileReadFile :: Assertion
 writeFileReadFile = do
   withSystemTempDirectory "test" $ \baseDir' -> do

windows/System/File/Platform.hsc

@@ -52,9 +52,22 @@ import "filepath" System.OsString.Internal.Types (WindowsString(..), WindowsChar
 import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC
 #endif
 
+import System.IO.Error (modifyIOError, ioeSetFileName)
+import GHC.IO.Encoding.UTF16 (mkUTF16le)
+import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))
+import Control.Exception (displayException, Exception)
+
+#if defined(LONG_PATHS)
+import System.IO.Error (ioeSetLocation, ioeGetLocation, catchIOError)
+import Data.Char (isAlpha, isAscii, toUpper)
+import qualified System.Win32.WindowsString.Info as WS
+#endif
+
 -- | Open a file and return the 'Handle'.
 openFile :: WindowsPath -> IOMode -> IO Handle
-openFile fp iomode = bracketOnError
+openFile fp' iomode = (`ioeSetWsPath` fp') `modifyIOError` do
+  fp <- furnishPath fp'
+  bracketOnError
     (WS.createFile
       fp
       accessMode
@@ -104,7 +117,9 @@ writeShareMode =
 
 -- | Open an existing file and return the 'Handle'.
 openExistingFile :: WindowsPath -> IOMode -> IO Handle
-openExistingFile fp iomode = bracketOnError
+openExistingFile fp' iomode = (`ioeSetWsPath` fp') `modifyIOError` do
+  fp <- furnishPath fp'
+  bracketOnError
     (WS.createFile
       fp
       accessMode
@@ -248,3 +263,20 @@ any_ = coerce BC.any
 
 #endif
 
+ioeSetWsPath :: IOError -> WindowsPath -> IOError
+ioeSetWsPath err =
+  ioeSetFileName err .
+  rightOrError .
+  WS.decodeWith (mkUTF16le TransliterateCodingFailure)
+
+rightOrError :: Exception e => Either e a -> a
+rightOrError (Left e)  = error (displayException e)
+rightOrError (Right a) = a
+
+-- inlined stuff from directory package
+furnishPath :: WindowsPath -> IO WindowsPath
+#if !defined(LONG_PATHS)
+furnishPath path = pure path
+#else
+furnishPath path = pure path
+#endif