diff --git a/haskell-lsp-types/haskell-lsp-types.cabal b/haskell-lsp-types/haskell-lsp-types.cabal index fa83ab70f..de5bd0cc7 100644 --- a/haskell-lsp-types/haskell-lsp-types.cabal +++ b/haskell-lsp-types/haskell-lsp-types.cabal @@ -48,6 +48,7 @@ library -- ghc-options: -Werror build-depends: base >= 4.9 && < 4.14 , aeson >=1.2.2.0 + , binary , bytestring , data-default , deepseq diff --git a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs index ff3d6f678..f2d94ea97 100644 --- a/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs +++ b/haskell-lsp-types/src/Language/Haskell/LSP/Types/Uri.hs @@ -1,15 +1,39 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} -module Language.Haskell.LSP.Types.Uri where +module Language.Haskell.LSP.Types.Uri + ( Uri(..) + , uriToFilePath + , filePathToUri + , NormalizedUri(..) + , toNormalizedUri + , fromNormalizedUri + , NormalizedFilePath(..) + , toNormalizedFilePath + , fromNormalizedFilePath + , normalizedFilePathToUri + , uriToNormalizedFilePath + -- Private functions + , platformAwareUriToFilePath + , platformAwareFilePathToUri + ) + where import Control.DeepSeq import qualified Data.Aeson as A +import Data.Binary (Binary, Get, put, get) import Data.Hashable +import Data.List (isPrefixOf, stripPrefix) +#if __GLASGOW_HASKELL__ < 804 +import Data.Monoid ((<>)) +#endif +import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics import Network.URI hiding (authority) +import qualified System.FilePath as FP import qualified System.FilePath.Posix as FPP import qualified System.FilePath.Windows as FPW import qualified System.Info @@ -19,10 +43,6 @@ newtype Uri = Uri { getUri :: Text } instance NFData Uri --- | When URIs are supposed to be used as keys, it is important to normalize --- the percent encoding in the URI since URIs that only differ --- when it comes to the percent-encoding should be treated as equivalent. --- -- If you care about performance then you should use a hash map. The keys -- are cached in order to make hashing very fast. data NormalizedUri = NormalizedUri !Int !Text @@ -35,11 +55,28 @@ instance Ord NormalizedUri where instance Hashable NormalizedUri where hash (NormalizedUri h _) = h +instance NFData NormalizedUri + +isUnescapedInUriPath :: SystemOS -> Char -> Bool +isUnescapedInUriPath systemOS c + | systemOS == windowsOS = isUnreserved c || c `elem` [':', '\\', '/'] + | otherwise = isUnreserved c || c == '/' + +-- | When URIs are supposed to be used as keys, it is important to normalize +-- the percent encoding in the URI since URIs that only differ +-- when it comes to the percent-encoding should be treated as equivalent. +normalizeUriEscaping :: String -> String +normalizeUriEscaping uri = + case stripPrefix (fileScheme ++ "//") uri of + Just p -> fileScheme ++ "//" ++ (escapeURIPath $ unEscapeString p) + Nothing -> escapeURIString isUnescapedInURI $ unEscapeString uri + where escapeURIPath = escapeURIString (isUnescapedInUriPath System.Info.os) + toNormalizedUri :: Uri -> NormalizedUri toNormalizedUri uri = NormalizedUri (hash norm) norm where (Uri t) = maybe uri filePathToUri (uriToFilePath uri) - -- To ensure all `Uri`s have the file path like the created ones by `filePathToUri` - norm = T.pack $ escapeURIString isUnescapedInURI $ unEscapeString $ T.unpack t + -- To ensure all `Uri`s have the file path normalized + norm = T.pack (normalizeUriEscaping (T.unpack t)) fromNormalizedUri :: NormalizedUri -> Uri fromNormalizedUri (NormalizedUri _ t) = Uri t @@ -55,6 +92,7 @@ type SystemOS = String uriToFilePath :: Uri -> Maybe FilePath uriToFilePath = platformAwareUriToFilePath System.Info.os +{-# WARNING platformAwareUriToFilePath "This function is considered private. Use normalizedFilePathToUri instead." #-} platformAwareUriToFilePath :: String -> Uri -> Maybe FilePath platformAwareUriToFilePath systemOS (Uri uri) = do URI{..} <- parseURI $ T.unpack uri @@ -74,12 +112,15 @@ platformAdjustFromUriPath systemOS authority srcPath = if systemOS /= windowsOS || null srcPath then srcPath else let firstSegment:rest = (FPP.splitDirectories . tail) srcPath -- Drop leading '/' for absolute Windows paths - drive = if FPW.isDrive firstSegment then FPW.addTrailingPathSeparator firstSegment else firstSegment + drive = if FPW.isDrive firstSegment + then FPW.addTrailingPathSeparator firstSegment + else firstSegment in FPW.joinDrive drive $ FPW.joinPath rest filePathToUri :: FilePath -> Uri -filePathToUri = platformAwareFilePathToUri System.Info.os +filePathToUri = (platformAwareFilePathToUri System.Info.os) . FP.normalise +{-# WARNING platformAwareFilePathToUri "This function is considered private. Use normalizedUriToFilePath instead." #-} platformAwareFilePathToUri :: SystemOS -> FilePath -> Uri platformAwareFilePathToUri systemOS fp = Uri . T.pack . show $ URI { uriScheme = fileScheme @@ -94,22 +135,62 @@ platformAdjustToUriPath systemOS srcPath | systemOS == windowsOS = '/' : escapedPath | otherwise = escapedPath where - (splitDirectories, splitDrive, normalise) + (splitDirectories, splitDrive) | systemOS == windowsOS = - (FPW.splitDirectories, FPW.splitDrive, FPW.normalise) + (FPW.splitDirectories, FPW.splitDrive) | otherwise = - (FPP.splitDirectories, FPP.splitDrive, FPP.normalise) + (FPP.splitDirectories, FPP.splitDrive) escapedPath = - case splitDrive (normalise srcPath) of + case splitDrive srcPath of (drv, rest) -> convertDrive drv `FPP.joinDrive` - FPP.joinPath (map (escapeURIString unescaped) $ splitDirectories rest) + FPP.joinPath (map (escapeURIString (isUnescapedInUriPath systemOS)) $ splitDirectories rest) -- splitDirectories does not remove the path separator after the drive so -- we do a final replacement of \ to / convertDrive drv | systemOS == windowsOS && FPW.hasTrailingPathSeparator drv = FPP.addTrailingPathSeparator (init drv) | otherwise = drv - unescaped c - | systemOS == windowsOS = isUnreserved c || c `elem` [':', '\\', '/'] - | otherwise = isUnreserved c || c == '/' + +-- | Newtype wrapper around FilePath that always has normalized slashes. +-- The NormalizedUri and hash of the FilePath are cached to avoided +-- repeated normalisation when we need to compute them (which is a lot). +-- +-- This is one of the most performance critical parts of ghcide, do not +-- modify it without profiling. +data NormalizedFilePath = NormalizedFilePath NormalizedUri !FilePath + deriving (Generic, Eq, Ord) + +instance NFData NormalizedFilePath + +instance Binary NormalizedFilePath where + put (NormalizedFilePath _ fp) = put fp + get = do + v <- Data.Binary.get :: Get FilePath + return (toNormalizedFilePath v) + +instance Show NormalizedFilePath where + show (NormalizedFilePath _ fp) = "NormalizedFilePath " ++ show fp + +instance Hashable NormalizedFilePath where + hash (NormalizedFilePath uri _) = hash uri + +instance IsString NormalizedFilePath where + fromString = toNormalizedFilePath + +toNormalizedFilePath :: FilePath -> NormalizedFilePath +toNormalizedFilePath fp = NormalizedFilePath nuri nfp + where nfp = FP.normalise fp + uriPath = platformAdjustToUriPath System.Info.os nfp + nuriStr = T.pack $ fileScheme <> "//" <> uriPath + nuri = NormalizedUri (hash nuriStr) nuriStr + +fromNormalizedFilePath :: NormalizedFilePath -> FilePath +fromNormalizedFilePath (NormalizedFilePath _ fp) = fp + +normalizedFilePathToUri :: NormalizedFilePath -> NormalizedUri +normalizedFilePathToUri (NormalizedFilePath uri _) = uri + +uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath +uriToNormalizedFilePath nuri = fmap (NormalizedFilePath nuri) mbFilePath + where mbFilePath = platformAwareUriToFilePath System.Info.os (fromNormalizedUri nuri) diff --git a/test/URIFilePathSpec.hs b/test/URIFilePathSpec.hs index 2e18ec91c..8726ca51d 100644 --- a/test/URIFilePathSpec.hs +++ b/test/URIFilePathSpec.hs @@ -2,31 +2,40 @@ {-# LANGUAGE OverloadedStrings #-} module URIFilePathSpec where +import Control.Monad (when) import Data.List #if __GLASGOW_HASKELL__ < 808 -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) #endif -import Data.Text (pack) +import Data.Text (Text, pack) import Language.Haskell.LSP.Types -import Network.URI -import qualified System.FilePath.Windows as FPW +import Network.URI import Test.Hspec import Test.QuickCheck #if !MIN_VERSION_QuickCheck(2,10,0) import Data.Char (GeneralCategory(..), generalCategory) #endif - +import qualified System.FilePath.Windows as FPW +import System.FilePath (normalise) +import qualified System.Info -- --------------------------------------------------------------------- +isWindows :: Bool +isWindows = System.Info.os == "mingw32" + main :: IO () main = hspec spec spec :: Spec spec = do + describe "Platform aware URI file path functions" platformAwareUriFilePathSpec describe "URI file path functions" uriFilePathSpec - describe "file path URI functions" filePathUriSpec describe "URI normalization functions" uriNormalizeSpec + describe "Normalized file path functions" normalizedFilePathSpec + +windowsOS :: String +windowsOS = "mingw32" testPosixUri :: Uri testPosixUri = Uri $ pack "file:///home/myself/example.hs" @@ -37,23 +46,14 @@ testPosixFilePath = "/home/myself/example.hs" relativePosixFilePath :: FilePath relativePosixFilePath = "myself/example.hs" -withCurrentDirPosixFilePath :: FilePath -withCurrentDirPosixFilePath = "/home/./myself/././example.hs" - testWindowsUri :: Uri -testWindowsUri = Uri $ pack "file:///C:/Users/myself/example.hs" +testWindowsUri = Uri $ pack "file:///c:/Users/myself/example.hs" testWindowsFilePath :: FilePath -testWindowsFilePath = "C:\\Users\\myself\\example.hs" - -testWindowsFilePathDriveLowerCase :: FilePath -testWindowsFilePathDriveLowerCase = "c:\\Users\\myself\\example.hs" - -withCurrentDirWindowsFilePath :: FilePath -withCurrentDirWindowsFilePath = "C:\\Users\\.\\myself\\.\\.\\example.hs" +testWindowsFilePath = "c:\\Users\\myself\\example.hs" -uriFilePathSpec :: Spec -uriFilePathSpec = do +platformAwareUriFilePathSpec :: Spec +platformAwareUriFilePathSpec = do it "converts a URI to a POSIX file path" $ do let theFilePath = platformAwareUriToFilePath "posix" testPosixUri theFilePath `shouldBe` Just testPosixFilePath @@ -70,43 +70,29 @@ uriFilePathSpec = do let theUri = platformAwareFilePathToUri windowsOS testWindowsFilePath theUri `shouldBe` testWindowsUri - it "removes unnecesary current directory paths" $ do - let theUri = platformAwareFilePathToUri "posix" withCurrentDirPosixFilePath - theUri `shouldBe` testPosixUri - - it "removes unnecesary current directory paths in windows" $ do - let theUri = platformAwareFilePathToUri windowsOS withCurrentDirWindowsFilePath - theUri `shouldBe` testWindowsUri - - it "make the drive letter upper case when converting a Windows file path to a URI" $ do - let theUri = platformAwareFilePathToUri windowsOS testWindowsFilePathDriveLowerCase - theUri `shouldBe` testWindowsUri - -filePathUriSpec :: Spec -filePathUriSpec = do it "converts a POSIX file path to a URI" $ do let theFilePath = platformAwareFilePathToUri "posix" "./Functional.hs" - theFilePath `shouldBe` (Uri "file://Functional.hs") + theFilePath `shouldBe` (Uri "file://./Functional.hs") it "converts a Windows file path to a URI" $ do let theFilePath = platformAwareFilePathToUri windowsOS "./Functional.hs" - theFilePath `shouldBe` (Uri "file:///Functional.hs") + theFilePath `shouldBe` (Uri "file:///./Functional.hs") it "converts a Windows file path to a URI" $ do let theFilePath = platformAwareFilePathToUri windowsOS "c:/Functional.hs" - theFilePath `shouldBe` (Uri "file:///C:/Functional.hs") + theFilePath `shouldBe` (Uri "file:///c:/Functional.hs") it "converts a POSIX file path to a URI and back" $ do let theFilePath = platformAwareFilePathToUri "posix" "./Functional.hs" - theFilePath `shouldBe` (Uri "file://Functional.hs") - let Just (URI scheme' auth' path' query' frag') = parseURI "file://Functional.hs" + theFilePath `shouldBe` (Uri "file://./Functional.hs") + let Just (URI scheme' auth' path' query' frag') = parseURI "file://./Functional.hs" (scheme',auth',path',query',frag') `shouldBe` ("file:" - ,Just (URIAuth {uriUserInfo = "", uriRegName = "Functional.hs", uriPort = ""}) -- AZ: Seems odd - ,"" + ,Just (URIAuth {uriUserInfo = "", uriRegName = ".", uriPort = ""}) -- AZ: Seems odd + ,"/Functional.hs" ,"" ,"") - Just "Functional.hs" `shouldBe` platformAwareUriToFilePath "posix" theFilePath + Just "./Functional.hs" `shouldBe` platformAwareUriToFilePath "posix" theFilePath it "converts a Posix file path to a URI and back" $ property $ forAll genPosixFilePath $ \fp -> do let uri = platformAwareFilePathToUri "posix" fp @@ -115,7 +101,9 @@ filePathUriSpec = do it "converts a Windows file path to a URI and back" $ property $ forAll genWindowsFilePath $ \fp -> do let uri = platformAwareFilePathToUri windowsOS fp -- We normalise to account for changes in the path separator. - platformAwareUriToFilePath windowsOS uri `shouldBe` Just (FPW.normalise fp) + -- But driver letters are *not* normalized so we skip them + when (not $ "c:" `isPrefixOf` fp) $ + platformAwareUriToFilePath windowsOS uri `shouldBe` Just (FPW.normalise fp) it "converts a relative POSIX file path to a URI and back" $ do let uri = platformAwareFilePathToUri "posix" relativePosixFilePath @@ -123,15 +111,135 @@ filePathUriSpec = do let back = platformAwareUriToFilePath "posix" uri back `shouldBe` Just relativePosixFilePath + +testUri :: Uri +testUri | isWindows = Uri "file:///C:/Users/myself/example.hs" + | otherwise = Uri "file:///home/myself/example.hs" + +testFilePath :: FilePath +testFilePath | isWindows = "C:\\Users\\myself\\example.hs" + | otherwise = "/home/myself/example.hs" + +withCurrentDirFilePath :: FilePath +withCurrentDirFilePath | isWindows = "C:\\Users\\.\\myself\\.\\.\\example.hs" + | otherwise = "/home/./myself/././example.hs" + +fromRelativefilePathUri :: Uri +fromRelativefilePathUri | isWindows = Uri "file:///myself/example.hs" + | otherwise = Uri "file://myself/example.hs" + +relativeFilePath :: FilePath +relativeFilePath | isWindows = "myself\\example.hs" + | otherwise = "myself/example.hs" + +withLowerCaseDriveLetterFilePath :: FilePath +withLowerCaseDriveLetterFilePath = "c:\\Users\\.\\myself\\.\\.\\example.hs" + +withInitialCurrentDirUriStr :: String +withInitialCurrentDirUriStr | isWindows = "file:///Functional.hs" + | otherwise = "file://Functional.hs" + +withInitialCurrentDirUriParts :: (String, Maybe URIAuth, String, String, String) +withInitialCurrentDirUriParts + | isWindows = + ("file:" + ,Just (URIAuth {uriUserInfo = "", uriRegName = "", uriPort = ""}) -- JNS: And asymmetrical + ,"/Functional.hs","","") + | otherwise = + ("file:" + ,Just (URIAuth {uriUserInfo = "", uriRegName = "Functional.hs", uriPort = ""}) -- AZ: Seems odd + ,"","","") + +withInitialCurrentDirFilePath :: FilePath +withInitialCurrentDirFilePath | isWindows = ".\\Functional.hs" + | otherwise = "./Functional.hs" + +noNormalizedUriTxt :: Text +noNormalizedUriTxt | isWindows = "file:///c:/Users/./myself/././example.hs" + | otherwise = "file:///home/./myself/././example.hs" + +noNormalizedUri :: Uri +noNormalizedUri = Uri noNormalizedUriTxt + +uriFilePathSpec :: Spec +uriFilePathSpec = do + it "converts a URI to a file path" $ do + let theFilePath = uriToFilePath testUri + theFilePath `shouldBe` Just testFilePath + + it "converts a file path to a URI" $ do + let theUri = filePathToUri testFilePath + theUri `shouldBe` testUri + + it "removes unnecesary current directory paths" $ do + let theUri = filePathToUri withCurrentDirFilePath + theUri `shouldBe` testUri + + when isWindows $ + it "make the drive letter upper case when converting a Windows file path to a URI" $ do + let theUri = filePathToUri withLowerCaseDriveLetterFilePath + theUri `shouldBe` testUri + + it "converts a file path to a URI and back" $ property $ forAll genFilePath $ \fp -> do + let uri = filePathToUri fp + uriToFilePath uri `shouldBe` Just (normalise fp) + + it "converts a relative file path to a URI and back" $ do + let uri = filePathToUri relativeFilePath + uri `shouldBe` fromRelativefilePathUri + let back = uriToFilePath uri + back `shouldBe` Just relativeFilePath + + it "converts a file path with initial current dir to a URI and back" $ do + let uri = filePathToUri withInitialCurrentDirFilePath + uri `shouldBe` (Uri (pack withInitialCurrentDirUriStr)) + let Just (URI scheme' auth' path' query' frag') = parseURI withInitialCurrentDirUriStr + (scheme',auth',path',query',frag') `shouldBe` withInitialCurrentDirUriParts + Just "Functional.hs" `shouldBe` uriToFilePath uri + uriNormalizeSpec :: Spec uriNormalizeSpec = do - it "ignores differences in percent-encoding" $ property $ \uri -> do + + it "ignores differences in percent-encoding" $ property $ \uri -> toNormalizedUri (Uri $ pack $ escapeURIString isUnescapedInURI uri) `shouldBe` toNormalizedUri (Uri $ pack $ escapeURIString (const False) uri) + it "ignores differences in percent-encoding (examples)" $ do + toNormalizedUri (Uri $ pack "http://server/path%C3%B1?param=%C3%B1") `shouldBe` + toNormalizedUri (Uri $ pack "http://server/path%c3%b1?param=%c3%b1") + toNormalizedUri (Uri $ pack "file:///path%2A") `shouldBe` + toNormalizedUri (Uri $ pack "file:///path%2a") + + it "normalizes uri file path when converting from uri to normalized uri" $ do + let (NormalizedUri _ uri) = toNormalizedUri noNormalizedUri + let (Uri nuri) = testUri + uri `shouldBe` nuri + + it "converts a file path with reserved uri chars to a normalized URI and back" $ do + let start = if isWindows then "C:\\" else "/" + let fp = start ++ "path;part#fragmen?param=val" + let nuri = toNormalizedUri (filePathToUri fp) + uriToFilePath (fromNormalizedUri nuri) `shouldBe` Just fp + + it "converts a file path with substrings that looks like uri escaped chars and back" $ do + let start = if isWindows then "C:\\" else "/" + let fp = start ++ "ca%C3%B1a" + let nuri = toNormalizedUri (filePathToUri fp) + uriToFilePath (fromNormalizedUri nuri) `shouldBe` Just fp + + it "converts a file path to a normalized URI and back" $ property $ forAll genFilePath $ \fp -> do + let nuri = toNormalizedUri (filePathToUri fp) + case uriToFilePath (fromNormalizedUri nuri) of + Just nfp -> nfp `shouldBe` (normalise fp) + Nothing -> return () -- Some unicode paths creates invalid uris, ignoring for now + +genFilePath :: Gen FilePath +genFilePath | isWindows = genWindowsFilePath + | otherwise = genPosixFilePath + genWindowsFilePath :: Gen FilePath genWindowsFilePath = do - segments <- listOf pathSegment + segments <- listOf1 pathSegment pathSep <- elements ['/', '\\'] driveLetter <- elements ["C:", "c:"] pure (driveLetter <> [pathSep] <> intercalate [pathSep] segments) @@ -139,7 +247,7 @@ genWindowsFilePath = do genPosixFilePath :: Gen FilePath genPosixFilePath = do - segments <- listOf pathSegment + segments <- listOf1 pathSegment pure ("/" <> intercalate "/" segments) where pathSegment = listOf1 (genValidUnicodeChar `suchThat` (`notElem` ['/'])) @@ -154,3 +262,32 @@ arbitraryUnicodeChar = where isSurrogate c = generalCategory c == Surrogate #endif + +normalizedFilePathSpec :: Spec +normalizedFilePathSpec = do + it "makes file path normalized" $ property $ forAll genFilePath $ \fp -> do + let nfp = toNormalizedFilePath fp + fromNormalizedFilePath nfp `shouldBe` (normalise fp) + + it "converts to a normalized uri and back" $ property $ forAll genFilePath $ \fp -> do + let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) + case uriToNormalizedFilePath nuri of + Just nfp -> fromNormalizedFilePath nfp `shouldBe` (normalise fp) + Nothing -> return () -- Some unicode paths creates invalid uris, ignoring for now + + it "converts a file path with reserved uri chars to a normalized URI and back" $ do + let start = if isWindows then "C:\\" else "/" + let fp = start ++ "path;part#fragmen?param=val" + let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) + fmap fromNormalizedFilePath (uriToNormalizedFilePath nuri) `shouldBe` Just fp + + it "converts a file path with substrings that looks like uri escaped chars and back" $ do + let start = if isWindows then "C:\\" else "/" + let fp = start ++ "ca%C3%B1a" + let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) + fmap fromNormalizedFilePath (uriToNormalizedFilePath nuri) `shouldBe` Just fp + + it "creates the same NormalizedUri than the older implementation" $ property $ forAll genFilePath $ \fp -> do + let nuri = normalizedFilePathToUri (toNormalizedFilePath fp) + let oldNuri = toNormalizedUri (filePathToUri fp) + nuri `shouldBe` oldNuri