Windows: Work around win32 length limits when dealing with lock files

Utility/LockFile/Windows.hs

@@ -1,10 +1,12 @@
 {- Windows lock files
  -
- - Copyright 2014 Joey Hess <id@joeyh.name>
+ - Copyright 2014,2021 Joey Hess <id@joeyh.name>
  -
  - License: BSD-2-clause
  -}
 
+{-# LANGUAGE OverloadedStrings #-}
+
 module Utility.LockFile.Windows (
 	lockShared,
 	lockExclusive,
@@ -16,8 +18,12 @@ module Utility.LockFile.Windows (
 import System.Win32.Types
 import System.Win32.File
 import Control.Concurrent
+import qualified Data.ByteString as B
+import qualified System.FilePath.Windows.ByteString as P
 
 import Utility.FileSystemEncoding
+import Utility.Split
+import Utility.Path.AbsRel
 
 type LockFile = RawFilePath
 
@@ -53,7 +59,8 @@ lockExclusive = openLock fILE_SHARE_NONE
  -}
 openLock :: ShareMode -> LockFile -> IO (Maybe LockHandle)
 openLock sharemode f = do
-	h <- withTString (fromRawFilePath f) $ \c_f ->
+	f' <- convertToNativeNamespace f
+	h <- withTString (fromRawFilePath f') $ \c_f ->
 		c_CreateFile c_f gENERIC_READ sharemode security_attributes
 			oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing)
 	return $ if h == iNVALID_HANDLE_VALUE
@@ -62,6 +69,32 @@ openLock sharemode f = do
   where
 	security_attributes = maybePtr Nothing
 
+{- Convert a filepath to use Windows's native namespace.
+ - This avoids filesystem length limits.
+ -
+ - This is similar to the way base converts filenames on windows,
+ - but as that is implemented in C (create_device_name) and not
+ - exported, it cannot be used here. Several edge cases are not handled,
+ - including network shares and dos short paths. 
+ -}
+convertToNativeNamespace :: RawFilePath -> IO RawFilePath
+convertToNativeNamespace f
+	| win32_dev_namespace `B.isPrefixOf` f = return f
+	| win32_file_namespace `B.isPrefixOf` f = return f
+	| nt_device_namespace `B.isPrefixOf` f = return f
+	| otherwise = do
+		-- Make absolute because any '.' and '..' in the path
+		-- will not be resolved once it's converted.
+		p <- absPath f
+		-- Normalize slashes.
+		let p' = P.normalise p
+		return (win32_file_namespace <> p')
+  where
+ 
+	win32_dev_namespace = "\\\\.\\"
+	win32_file_namespace = "\\\\?\\"
+	nt_device_namespace = "\\Device\\"
+
 dropLock :: LockHandle -> IO ()
 dropLock = closeHandle