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
+  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

windows/System/File/Platform.hsc

@@ -4,18 +4,23 @@
 
 module System.File.Platform where
 
-import Control.Exception (bracketOnError, try, SomeException, onException)
+import Control.Exception (bracketOnError, try, SomeException, onException, displayException, Exception)
 import Data.Bits
 import Data.Maybe (fromJust)
 import System.IO (IOMode(..), Handle)
 import System.OsPath.Windows ( WindowsPath )
 import qualified System.OsPath.Windows as WS
 import Foreign.C.Types
 
+import System.IO.Error (ioeSetFileName, modifyIOError, ioeSetLocation, ioeGetLocation)
+import Data.Char (isAlpha, isAscii, toUpper)
 import qualified System.OsString.Windows as WS hiding (decodeFS)
 import System.OsString.Windows ( encodeUtf, WindowsString )
+import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))
+import GHC.IO.Encoding.UTF16 (mkUTF16le)
 import qualified System.Win32 as Win32
 import qualified System.Win32.WindowsString.File as WS
+import qualified System.Win32.WindowsString.Info as WS
 import System.Win32.WindowsString.Types (withTString, peekTString)
 #if MIN_VERSION_Win32(2, 14, 0)
 import System.Win32.WindowsString.Types (withFilePath)
@@ -54,7 +59,9 @@ import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC
 
 -- | Open a file and return the 'Handle'.
 openFile :: WindowsPath -> IOMode -> IO Handle
-openFile fp iomode = bracketOnError
+openFile fp' iomode = do
+  fp <- furnishPath fp'
+  bracketOnError
     (WS.createFile
       fp
       accessMode
@@ -104,7 +111,9 @@ writeShareMode =
 
 -- | Open an existing file and return the 'Handle'.
 openExistingFile :: WindowsPath -> IOMode -> IO Handle
-openExistingFile fp iomode = bracketOnError
+openExistingFile fp' iomode = do
+  fp <- furnishPath fp'
+  bracketOnError
     (WS.createFile
       fp
       accessMode
@@ -248,3 +257,138 @@ any_ = coerce BC.any
 
 #endif
 
+furnishPath :: WindowsPath -> IO WindowsPath
+#if !defined(LONG_PATHS)
+furnishPath path = pure path
+#else
+furnishPath path =
+  (toExtendedLengthPath <$> rawPrependCurrentDirectory path)
+    `catchIOError` \ _ ->
+      pure path
+
+toExtendedLengthPath :: WindowsPath -> WindowsPath
+toExtendedLengthPath path =
+  if WS.isRelative path
+  then simplifiedPath
+  else
+    case WS.toChar <$> simplifiedPath' of
+      '\\' : '?'  : '?' : '\\' : _ -> simplifiedPath
+      '\\' : '\\' : '?' : '\\' : _ -> simplifiedPath
+      '\\' : '\\' : '.' : '\\' : _ -> simplifiedPath
+      '\\' : '\\' : _ ->
+        os "\\\\?\\UNC" <> WS.pack (drop 1 simplifiedPath')
+      _ -> os "\\\\?\\" <> simplifiedPath
+  where simplifiedPath = simplifyWindows path
+        simplifiedPath' = WS.unpack simplifiedPath
+
+rawPrependCurrentDirectory :: WindowsPath -> IO WindowsPath
+rawPrependCurrentDirectory path
+  | WS.isRelative path =
+    ((`ioeAddLocation` "prependCurrentDirectory") .
+     (`ioeSetWsPath` path)) `modifyIOError` do
+      getFullPathName path
+  | otherwise = pure path
+
+simplifyWindows :: WindowsPath -> WindowsPath
+simplifyWindows path
+  | path == mempty         = mempty
+  | drive' == ws "\\\\?\\" = drive' <> subpath
+  | otherwise              = simplifiedPath
+  where
+    simplifiedPath = WS.joinDrive drive' subpath'
+    (drive, subpath) = WS.splitDrive path
+    drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive))
+    subpath' = appendSep . avoidEmpty . prependSep . WS.joinPath .
+               stripPardirs . expandDots . skipSeps .
+               WS.splitDirectories $ subpath
+
+    upperDrive d = case WS.unpack d of
+      c : k : s
+        | isAlpha (WS.toChar c), WS.toChar k == ':', all WS.isPathSeparator s ->
+          -- unsafeFromChar is safe here since all characters are ASCII.
+          WS.pack (WS.unsafeFromChar (toUpper (WS.toChar c)) : WS.unsafeFromChar ':' : s)
+      _ -> d
+    skipSeps =
+      (WS.pack <$>) .
+      filter (not . (`elem` (pure <$> WS.pathSeparators))) .
+      (WS.unpack <$>)
+    stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== ws "..")
+                 | otherwise = id
+    prependSep | subpathIsAbsolute = (WS.pack [WS.pathSeparator] <>)
+               | otherwise = id
+    avoidEmpty | not pathIsAbsolute
+               , drive == mempty || hasTrailingPathSep -- prefer "C:" over "C:."
+                 = emptyToCurDir
+               | otherwise = id
+    appendSep p | hasTrailingPathSep, not (pathIsAbsolute && p == mempty)
+                  = WS.addTrailingPathSeparator p
+                | otherwise = p
+    pathIsAbsolute = not (WS.isRelative path)
+    subpathIsAbsolute = any WS.isPathSeparator (take 1 (WS.unpack subpath))
+    hasTrailingPathSep = WS.hasTrailingPathSeparator subpath
+
+-- | Remove redundant trailing slashes and pick the right kind of slash.
+normaliseTrailingSep :: WindowsPath -> WindowsPath
+normaliseTrailingSep path = do
+  let path' = reverse (WS.unpack path)
+  let (sep, path'') = span WS.isPathSeparator path'
+  let addSep = if null sep then id else (WS.pathSeparator :)
+  pack (reverse (addSep path''))
+
+normalisePathSeps :: WindowsPath -> WindowsPath
+normalisePathSeps p = WS.pack (normaliseChar <$> WS.unpack p)
+  where normaliseChar c = if WS.isPathSeparator c then WS.pathSeparator else c
+
+emptyToCurDir :: WindowsPath -> WindowsPath
+emptyToCurDir path
+  | path == mempty = ws "."
+  | otherwise      = path
+
+ws :: String -> WindowsString
+ws = rightOrError . WS.encodeUtf
+
+rightOrError :: Exception e => Either e a -> a
+rightOrError (Left e)  = error (displayException e)
+rightOrError (Right a) = a
+
+getFullPathName :: WindowsPath -> IO WindowsPath
+getFullPathName path =
+  fromExtendedLengthPath <$> WS.getFullPathName (toExtendedLengthPath path)
+
+ioeSetWsPath :: IOError -> WindowsPath -> IOError
+ioeSetWsPath err =
+  ioeSetFileName err .
+  rightOrError .
+  WS.decodeWith (mkUTF16le TransliterateCodingFailure)
+
+ioeAddLocation :: IOError -> String -> IOError
+ioeAddLocation e loc = do
+  ioeSetLocation e newLoc
+  where
+    newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc
+    oldLoc = ioeGetLocation e
+
+fromExtendedLengthPath :: WindowsPath -> WindowsPath
+fromExtendedLengthPath ePath =
+  case WS.unpack ePath of
+    c1 : c2 : c3 : c4 : path
+      | (WS.toChar <$> [c1, c2, c3, c4]) == "\\\\?\\" ->
+      case path of
+        c5 : c6 : c7 : subpath@(c8 : _)
+          | (WS.toChar <$> [c5, c6, c7, c8]) == "UNC\\" ->
+            WS.pack (c8 : subpath)
+        drive : col : subpath
+          -- if the path is not "regular", then the prefix is necessary
+          -- to ensure the path is interpreted literally
+          | WS.toChar col == ':', isDriveChar drive, isPathRegular subpath ->
+            WS.pack path
+        _ -> ePath
+    _ -> ePath
+  where
+    isDriveChar drive = isAlpha (WS.toChar drive) && isAscii (WS.toChar drive)
+    isPathRegular path =
+      not ('/' `elem` (WS.toChar <$> path) ||
+           ws "." `elem` WS.splitDirectories (WS.pack path) ||
+           ws ".." `elem` WS.splitDirectories (WS.pack path))
+
+#endif