hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Use file-uri for better URI handling, fixes #978

Browse Source
This commit is contained in:
Julian Ospald 2024-01-20 18:23:08 +08:00
parent 950155cbe3
commit 4b3ffd8570
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
7 changed files with 68 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
ghcup.cabal
View File

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

9
lib-opt/GHCup/OptParse/Common.hs
View File

@ -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')

5
lib/GHCup/Download.hs
View File

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

5
lib/GHCup/Download/IOStreams.hs
View File

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

5
lib/GHCup/Types/JSON.hs
View File

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

4
lib/GHCup/Utils.hs
View File

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

49
lib/GHCup/Utils/URI.hs Normal file
View File

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