From 4b3ffd857053ffd7f2059557267939560534688a Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 20 Jan 2024 18:23:08 +0800 Subject: [PATCH] Use file-uri for better URI handling, fixes #978 --- ghcup.cabal | 2 ++ lib-opt/GHCup/OptParse/Common.hs | 9 +++--- lib/GHCup/Download.hs | 5 ++-- lib/GHCup/Download/IOStreams.hs | 5 ++-- lib/GHCup/Types/JSON.hs | 5 ++-- lib/GHCup/Utils.hs | 4 ++- lib/GHCup/Utils/URI.hs | 49 ++++++++++++++++++++++++++++++++ 7 files changed, 68 insertions(+), 11 deletions(-) create mode 100644 lib/GHCup/Utils/URI.hs diff --git a/ghcup.cabal b/ghcup.cabal index 97641b8..3230d56 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -142,6 +142,7 @@ library GHCup.Utils.Dirs GHCup.Utils.Tar GHCup.Utils.Tar.Types + GHCup.Utils.URI GHCup.Version hs-source-dirs: lib @@ -184,6 +185,7 @@ library , disk-free-space ^>=0.1.0.1 , exceptions ^>=0.10 , filepath ^>=1.4.2.1 + , file-uri ^>=0.1.0.0 , haskus-utils-types ^>=1.5 , haskus-utils-variant ^>=3.3 , lzma-static ^>=5.2.5.3 diff --git a/lib-opt/GHCup/OptParse/Common.hs b/lib-opt/GHCup/OptParse/Common.hs index 597b9d7..4c8fad3 100644 --- a/lib-opt/GHCup/OptParse/Common.hs +++ b/lib-opt/GHCup/OptParse/Common.hs @@ -17,6 +17,7 @@ import GHCup.Platform import GHCup.Types import GHCup.Types.Optics import GHCup.Utils +import GHCup.Utils.URI import GHCup.Prelude import GHCup.Prelude.Process import GHCup.Prelude.Logger @@ -59,7 +60,7 @@ import Safe import System.Process ( readProcess ) import System.FilePath import Text.HTML.TagSoup hiding ( Tag ) -import URI.ByteString +import URI.ByteString hiding (parseURI) import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.Map.Strict as M @@ -215,7 +216,7 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of uriParser :: String -> Either String URI -uriParser = first show . parseURI strictURIParserOptions . UTF8.fromString +uriParser = first show . parseURI . UTF8.fromString absolutePathParser :: FilePath -> Either String FilePath @@ -834,11 +835,11 @@ parseUrlSource :: String -> Either String URLSource parseUrlSource "GHCupURL" = pure GHCupURL parseUrlSource "StackSetupURL" = pure StackSetupURL parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') - <|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI strictURIParserOptions .UTF8.fromString $ s') + <|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI .UTF8.fromString $ s') parseNewUrlSource :: String -> Either String NewURLSource parseNewUrlSource "GHCupURL" = pure NewGHCupURL parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') - <|> (fmap NewURI . first show . parseURI strictURIParserOptions .UTF8.fromString $ s') + <|> (fmap NewURI . first show . parseURI .UTF8.fromString $ s') diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index a6e840b..3cf3116 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -34,6 +34,7 @@ import qualified GHCup.Types.Stack as Stack import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs +import GHCup.Utils.URI import GHCup.Platform import GHCup.Prelude import GHCup.Prelude.File @@ -77,7 +78,7 @@ import System.Exit import System.FilePath import System.IO.Error import System.IO.Temp -import URI.ByteString +import URI.ByteString hiding (parseURI) import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.ByteString as B @@ -178,7 +179,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do fromStackDownloadInfo :: MonadThrow m => Stack.GHCDownloadInfo -> m DownloadInfo fromStackDownloadInfo (Stack.GHCDownloadInfo { gdiDownloadInfo = Stack.DownloadInfo{..} }) = do - url <- either (\e -> throwM $ ParseError (show e)) pure $ parseURI strictURIParserOptions . E.encodeUtf8 $ downloadInfoUrl + url <- either (\e -> throwM $ ParseError (show e)) pure $ parseURI . E.encodeUtf8 $ downloadInfoUrl sha256 <- maybe (throwM $ DigestMissing url) (pure . E.decodeUtf8) downloadInfoSha256 pure $ DownloadInfo url (Just $ RegexDir "ghc-.*") sha256 Nothing Nothing diff --git a/lib/GHCup/Download/IOStreams.hs b/lib/GHCup/Download/IOStreams.hs index 3a396f6..adc9f14 100644 --- a/lib/GHCup/Download/IOStreams.hs +++ b/lib/GHCup/Download/IOStreams.hs @@ -11,6 +11,7 @@ import GHCup.Download.Utils import GHCup.Errors import GHCup.Types.JSON ( ) import GHCup.Prelude +import GHCup.Utils.URI import Control.Applicative import Control.Exception.Safe @@ -28,7 +29,7 @@ import Prelude hiding ( abs , writeFile ) import System.ProgressBar -import URI.ByteString +import URI.ByteString hiding (parseURI) import qualified Data.ByteString as BS import qualified Data.Map.Strict as M @@ -114,7 +115,7 @@ downloadInternal = go (5 :: Int) | otherwise -> throwE $ HTTPStatusError scode (getHeaderMap r) ) - followRedirectURL bs = case parseURI strictURIParserOptions bs of + followRedirectURL bs = case parseURI bs of Right uri' -> do (https', host', fullPath', port') <- liftE $ uriToQuadruple uri' go (redirs - 1) progressBar https' host' fullPath' port' consumer setup addHeaders eCSize diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 99c281a..ce95303 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -26,6 +26,7 @@ import GHCup.Types.Stack (SetupInfo) import GHCup.Types.JSON.Utils import GHCup.Types.JSON.Versions () import GHCup.Prelude.MegaParsec +import GHCup.Utils.URI import Control.Applicative ( (<|>) ) import Data.Aeson hiding (Key) @@ -38,7 +39,7 @@ import Data.Text.Encoding as E import Data.Foldable import Data.Versions import Data.Void -import URI.ByteString +import URI.ByteString hiding (parseURI) import Text.Casing import qualified Data.List.NonEmpty as NE @@ -95,7 +96,7 @@ instance ToJSON URI where instance FromJSON URI where parseJSON = withText "URL" $ \t -> - case parseURI strictURIParserOptions (encodeUtf8 t) of + case parseURI (encodeUtf8 t) of Right x -> pure x Left e -> fail . show $ e diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 310b5fa..551e679 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -23,6 +23,7 @@ module GHCup.Utils ( module GHCup.Utils.Dirs , module GHCup.Utils.Tar , module GHCup.Utils + , module GHCup.Utils.URI #if defined(IS_WINDOWS) , module GHCup.Prelude.Windows #else @@ -44,6 +45,7 @@ import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs import GHCup.Utils.Tar +import GHCup.Utils.URI import GHCup.Version import GHCup.Prelude import GHCup.Prelude.File @@ -78,7 +80,7 @@ import System.FilePath import System.IO.Error import Text.Regex.Posix import Text.PrettyPrint.HughesPJClass (prettyShow) -import URI.ByteString +import URI.ByteString hiding (parseURI) import qualified Data.Map.Strict as Map import qualified Data.Text as T diff --git a/lib/GHCup/Utils/URI.hs b/lib/GHCup/Utils/URI.hs new file mode 100644 index 0000000..b80be33 --- /dev/null +++ b/lib/GHCup/Utils/URI.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.Utils.URI +Description : GHCup domain specific URI utilities +Copyright : (c) Julian Ospald, 2024 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable + +This module contains GHCup helpers specific to +URI handling. +-} +module GHCup.Utils.URI where + +import Data.ByteString +import URI.ByteString hiding (parseURI) +import System.URI.File + +import qualified URI.ByteString as URI + + + ----------- + --[ URI ]-- + ----------- + + +parseURI :: ByteString -> Either URIParseError (URIRef Absolute) +parseURI bs = case parseFile bs of + Left _ -> case URI.parseURI strictURIParserOptions bs of + Right (URI { uriScheme = (Scheme "file") }) -> +#if defined(IS_WINDOWS) + Left (OtherError "Invalid file URI. File URIs must be absolute (start with a drive letter or UNC path) and not contain backslashes.") +#else + Left (OtherError "Invalid file URI. File URIs must be absolute.") +#endif + o -> o + Right (FileURI (Just _) _) -> Left $ OtherError "File URIs with auth part are not supported!" + Right (FileURI _ fp) -> Right $ URI (Scheme "file") Nothing fp (Query []) Nothing + where + parseFile +#if defined(IS_WINDOWS) + = parseFileURI ExtendedWindows +#else + = parseFileURI ExtendedPosix +#endif +