This commit is contained in:
parent
18f891f261
commit
b87d252fec
13
README.md
13
README.md
|
|
@ -1,28 +1,25 @@
|
|||
# ghcup
|
||||
|
||||
A rewrite of ghcup in haskell. This can be used as a library
|
||||
and may be redistributed as a binary in the future.
|
||||
A rewrite of ghcup in haskell.
|
||||
|
||||
## Motivation
|
||||
|
||||
ghcup has increasingly become difficult to maintain. A few reasons:
|
||||
Maintenance problems:
|
||||
|
||||
* few maintainers
|
||||
* increasing LOC
|
||||
* platform incompatibilities regularly causing breaking bugs:
|
||||
* [Mktemp not working properly on macOS](https://gitlab.haskell.org/haskell/ghcup/issues/130)
|
||||
* [ln: illegal option -- T on macOS Catalina](https://gitlab.haskell.org/haskell/ghcup/issues/123)
|
||||
* [Wrong tar flag on darwin](https://gitlab.haskell.org/haskell/ghcup/issues/119))
|
||||
* refactoring being difficult due to POSIX sh
|
||||
|
||||
More benefits of a rewrite:
|
||||
Benefits of a rewrite:
|
||||
|
||||
* Features such as installing [release candidates](https://gitlab.haskell.org/haskell/ghcup/issues/94) or [HEAD builds](https://gitlab.haskell.org/haskell/ghcup/issues/65) can be more conveniently implemented in a rewrite
|
||||
* Refactoring will be easier
|
||||
* Better tool support (such as linting the downloads file)
|
||||
* saner downloads file format (such as JSON)
|
||||
|
||||
However, the downside will be:
|
||||
Downsides:
|
||||
|
||||
* building static binaries for all platforms (and possibly causing SSL/DNS problems)
|
||||
* still bootstrapping those binaries via a POSIX sh script
|
||||
|
|
@ -31,4 +28,4 @@ However, the downside will be:
|
|||
|
||||
* Correct low-level code
|
||||
* Good exception handling
|
||||
* Easier user interface (possibly interactive and non-interactive ones)
|
||||
* Cleaner user interface
|
||||
|
|
|
|||
11
TODO.md
11
TODO.md
|
|
@ -4,8 +4,6 @@
|
|||
|
||||
* print-system-reqs
|
||||
|
||||
* set proper ghcup URL
|
||||
|
||||
## Cleanups
|
||||
|
||||
* avoid alternative for IO
|
||||
|
|
@ -31,16 +29,13 @@
|
|||
|
||||
## Questions
|
||||
|
||||
* how to figure out tools (currently not done, but when setting ghc symlinks, removes all previous tools before symlinking requested version to avoid stale tools that only exist for one version)
|
||||
* handling of SIGTERM and SIGUSR
|
||||
* installing musl on demand?
|
||||
* redo/rethink how tool tags works
|
||||
* tarball tags as well as version tags?
|
||||
* mirror support
|
||||
* check for new version on start
|
||||
* tarball tags as well as version tags?
|
||||
* installing multiple versions in parallel?
|
||||
* how to version and extend the format of the downloads file? Compatibility?
|
||||
* how to propagate updates? Automatically? Might solve the versioning problem
|
||||
* how to propagate updates? Automatically? Might solve the versioning problem
|
||||
* maybe add deprecation notice into JSON
|
||||
* interactive handling when distro doesn't exist and we know the tarball is incompatible?
|
||||
* ghcup-with wrapper to execute a command with a given ghc in PATH?
|
||||
* maybe add deprecation notice into JSON
|
||||
|
|
|
|||
|
|
@ -390,8 +390,6 @@ upgradeOptsP =
|
|||
|
||||
|
||||
|
||||
-- TODO: something better than Show instance for errors
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
|
|
|
|||
|
|
@ -35,6 +35,8 @@ constraints: any.Cabal ==2.4.0.1,
|
|||
bifunctors +semigroups +tagged,
|
||||
any.binary ==0.8.6.0,
|
||||
any.blaze-builder ==0.4.1.0,
|
||||
any.brotli ==0.0.0.0,
|
||||
any.brotli-streams ==0.0.0.0,
|
||||
any.bytestring ==0.10.8.2,
|
||||
any.bytestring-builder ==0.10.8.2.0,
|
||||
bytestring-builder +bytestring_has_builder,
|
||||
|
|
@ -59,7 +61,7 @@ constraints: any.Cabal ==2.4.0.1,
|
|||
any.data-default-instances-base ==0.1.0.1,
|
||||
any.deepseq ==1.4.4.0,
|
||||
any.deferred-folds ==0.9.10.1,
|
||||
any.directory ==1.3.3.0,
|
||||
any.directory ==1.3.3.0 || ==1.3.6.0,
|
||||
any.distributive ==0.6.1,
|
||||
distributive +semigroups +tagged,
|
||||
any.dlist ==0.8.0.7,
|
||||
|
|
@ -96,7 +98,8 @@ constraints: any.Cabal ==2.4.0.1,
|
|||
any.hpath-posix ==0.13.1,
|
||||
any.hsc2hs ==0.68.6,
|
||||
hsc2hs -in-ghc-tree,
|
||||
any.http-io-streams ==0.1.0.0,
|
||||
any.http-io-streams ==0.1.2.0,
|
||||
http-io-streams +brotli,
|
||||
any.indexed-profunctors ==0.1,
|
||||
any.integer-gmp ==1.0.2.0,
|
||||
any.integer-logarithms ==1.0.3,
|
||||
|
|
@ -121,7 +124,7 @@ constraints: any.Cabal ==2.4.0.1,
|
|||
any.mono-traversable ==1.0.15.1,
|
||||
any.mtl ==2.2.2,
|
||||
any.mwc-random ==0.14.0.0,
|
||||
any.network ==3.0.1.1,
|
||||
any.network ==3.1.1.1,
|
||||
any.network-uri ==2.6.3.0,
|
||||
any.old-locale ==1.0.0.7,
|
||||
any.old-time ==1.1.0.3,
|
||||
|
|
@ -142,7 +145,7 @@ constraints: any.Cabal ==2.4.0.1,
|
|||
any.primitive ==0.7.0.1,
|
||||
any.primitive-extras ==0.8,
|
||||
any.primitive-unlifted ==0.1.3.0,
|
||||
any.process ==1.6.5.0,
|
||||
any.process ==1.6.5.0 || ==1.6.8.0,
|
||||
any.profunctors ==5.5.2,
|
||||
any.random ==1.1,
|
||||
any.recursion-schemes ==5.1.3,
|
||||
|
|
@ -192,7 +195,7 @@ constraints: any.Cabal ==2.4.0.1,
|
|||
any.th-reify-many ==0.1.9,
|
||||
any.these ==1.0.1,
|
||||
these +aeson +assoc +quickcheck +semigroupoids,
|
||||
any.time ==1.8.0.2,
|
||||
any.time ==1.8.0.2 || ==1.9.3,
|
||||
any.time-compat ==1.9.2.2,
|
||||
time-compat -old-locale,
|
||||
any.transformers ==0.5.6.2,
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@ common base { build-depends: base >= 4.12 && < 5 }
|
|||
common binary { build-depends: binary >= 0.8.6.0 }
|
||||
common bytestring { build-depends: bytestring >= 0.10 }
|
||||
common bzlib { build-depends: bzlib >= 0.5.0.5 }
|
||||
common case-insensitive { build-depends: case-insensitive >= 1.2.1.0 }
|
||||
common containers { build-depends: containers >= 0.6 }
|
||||
common generics-sop { build-depends: generics-sop >= 0.5 }
|
||||
common haskus-utils-types { build-depends: haskus-utils-types >= 1.5 }
|
||||
|
|
@ -40,7 +41,7 @@ common hpath-directory { build-depends: hpath-directory >= 0.13.2 }
|
|||
common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
|
||||
common hpath-io { build-depends: hpath-io >= 0.13.1 }
|
||||
common hpath-posix { build-depends: hpath-posix >= 0.11.1 }
|
||||
common http-io-streams { build-depends: http-io-streams >= 0.1 }
|
||||
common http-io-streams { build-depends: http-io-streams >= 0.1.2.0 }
|
||||
common io-streams { build-depends: io-streams >= 1.5 }
|
||||
common language-bash { build-depends: language-bash >= 0.9 }
|
||||
common lzma { build-depends: lzma >= 0.0.0.3 }
|
||||
|
|
@ -61,10 +62,11 @@ common strict-base { build-depends: strict-base >= 0.4 }
|
|||
common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 }
|
||||
common table-layout { build-depends: table-layout >= 0.8 }
|
||||
common tar-bytestring { build-depends: tar-bytestring >= 0.6.3.0 }
|
||||
common terminal-progress-bar { build-depends: terminal-progress-bar >= 0.4.1 }
|
||||
common template-haskell { build-depends: template-haskell >= 2.7 }
|
||||
common terminal-progress-bar { build-depends: terminal-progress-bar >= 0.4.1 }
|
||||
common text { build-depends: text >= 1.2 }
|
||||
common text-icu { build-depends: text-icu >= 0.7 }
|
||||
common time { build-depends: time >= 1.9.3 }
|
||||
common transformers { build-depends: transformers >= 0.5 }
|
||||
common unix { build-depends: unix >= 2.7 }
|
||||
common unix-bytestring { build-depends: unix-bytestring >= 0.3 }
|
||||
|
|
@ -101,6 +103,7 @@ library
|
|||
, binary
|
||||
, bytestring
|
||||
, bzlib
|
||||
, case-insensitive
|
||||
, containers
|
||||
, generics-sop
|
||||
, haskus-utils-types
|
||||
|
|
@ -134,6 +137,7 @@ library
|
|||
, terminal-progress-bar
|
||||
, text
|
||||
, text-icu
|
||||
, time
|
||||
, transformers
|
||||
, unix
|
||||
, unix-bytestring
|
||||
|
|
|
|||
23
lib/GHCup.hs
23
lib/GHCup.hs
|
|
@ -8,7 +8,6 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
-- TODO: handle SIGTERM, SIGUSR
|
||||
module GHCup where
|
||||
|
||||
|
||||
|
|
@ -216,8 +215,8 @@ installCabalBin bDls ver mpfReq = do
|
|||
-- on `SetGHC`:
|
||||
--
|
||||
-- * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||
-- * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||
-- * SetGHCMinor: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||
-- * SetGHC_XY: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||
-- * SetGHC_XYZ: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc
|
||||
--
|
||||
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
|
||||
-- for `SetGHCOnly` constructor.
|
||||
|
|
@ -236,22 +235,22 @@ setGHC ver sghc = do
|
|||
-- first delete the old symlinks (this fixes compatibility issues
|
||||
-- with old ghcup)
|
||||
case sghc of
|
||||
SetGHCOnly -> liftE $ rmPlain ver
|
||||
SetGHCMajor -> lift $ rmMajorSymlinks ver
|
||||
SetGHCMinor -> lift $ rmMinorSymlinks ver
|
||||
SetGHCOnly -> liftE $ rmPlain ver
|
||||
SetGHC_XY -> lift $ rmMajorSymlinks ver
|
||||
SetGHC_XYZ -> lift $ rmMinorSymlinks ver
|
||||
|
||||
-- for ghc tools (ghc, ghci, haddock, ...)
|
||||
verfiles <- ghcToolFiles ver
|
||||
forM_ verfiles $ \file -> do
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (bindir </> file)
|
||||
targetFile <- case sghc of
|
||||
SetGHCOnly -> pure file
|
||||
SetGHCMajor -> do
|
||||
SetGHCOnly -> pure file
|
||||
SetGHC_XY -> do
|
||||
major' <-
|
||||
(\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi)
|
||||
<$> getGHCMajor ver
|
||||
parseRel (toFilePath file <> B.singleton _hyphen <> major')
|
||||
SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
|
||||
SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
|
||||
|
||||
-- create symlink
|
||||
let fullF = bindir </> targetFile
|
||||
|
|
@ -383,7 +382,7 @@ rmGHCVer ver = do
|
|||
lift $ rmMajorSymlinks ver
|
||||
-- then fix them (e.g. with an earlier version)
|
||||
(mj, mi) <- getGHCMajor ver
|
||||
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
|
||||
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
|
||||
|
||||
|
||||
when isSetGHC $ do
|
||||
|
|
@ -679,9 +678,9 @@ postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
|
|||
=> Version
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
postGHCInstall ver = do
|
||||
liftE $ setGHC ver SetGHCMinor
|
||||
liftE $ setGHC ver SetGHC_XYZ
|
||||
|
||||
-- Create ghc-x.y symlinks. This may not be the current
|
||||
-- version, create it regardless.
|
||||
(mj, mi) <- liftIO $ getGHCMajor ver
|
||||
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
|
||||
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@ import GHCup.Utils.String.QQ
|
|||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
|
|
@ -31,10 +32,14 @@ import Control.Monad.Trans.Resource
|
|||
import Data.Aeson
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.ByteString.Builder
|
||||
import Data.CaseInsensitive ( CI )
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate
|
||||
import Data.Text.Read
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Clock.POSIX
|
||||
import Data.Time.Format
|
||||
import Data.Versions
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
|
|
@ -61,6 +66,9 @@ import URI.ByteString.QQ
|
|||
import qualified Data.Binary.Builder as B
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified System.IO.Streams as Streams
|
||||
import qualified System.Posix.RawFilePath.Directory
|
||||
|
|
@ -69,8 +77,7 @@ import qualified System.Posix.RawFilePath.Directory
|
|||
|
||||
|
||||
ghcupURL :: URI
|
||||
ghcupURL =
|
||||
[uri|https://gist.githubusercontent.com/hasufell/5411271eb4ae52e16ad2200f80eb2813/raw/eb47b3c9d85edf3a4df2b869f8a8eda87fa94bb4/gistfile1.txt|]
|
||||
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.1.json|]
|
||||
|
||||
|
||||
|
||||
|
|
@ -79,7 +86,7 @@ ghcupURL =
|
|||
------------------
|
||||
|
||||
|
||||
-- | Downloads the download information!
|
||||
-- | Downloads the download information! But only if we need to ;P
|
||||
getDownloads :: ( FromJSONKey Tool
|
||||
, FromJSONKey Version
|
||||
, FromJSON VersionInfo
|
||||
|
|
@ -87,6 +94,8 @@ getDownloads :: ( FromJSONKey Tool
|
|||
, MonadCatch m
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
)
|
||||
=> Excepts '[JSONError , DownloadFailed] m GHCupDownloads
|
||||
getDownloads = do
|
||||
|
|
@ -94,13 +103,85 @@ getDownloads = do
|
|||
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
|
||||
case urlSource of
|
||||
GHCupURL -> do
|
||||
bs <- reThrowAll DownloadFailed $ downloadBS ghcupURL
|
||||
bs <- reThrowAll DownloadFailed $ dl ghcupURL
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSource url) -> do
|
||||
bs <- reThrowAll DownloadFailed $ downloadBS url
|
||||
bs <- reThrowAll DownloadFailed $ dl url
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSpec av) -> pure $ av
|
||||
|
||||
where
|
||||
-- First send a HEAD request and check for modification time.
|
||||
-- Only download the file if the modification time is newer
|
||||
-- than the local file. Always save the local file with the
|
||||
-- mod time of the remote file.
|
||||
dl :: forall m1
|
||||
. (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ FileDoesNotExistError
|
||||
, HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
]
|
||||
m1
|
||||
L.ByteString
|
||||
dl uri' = do
|
||||
let path = view pathL' uri'
|
||||
json_file <- (liftIO $ ghcupCacheDir)
|
||||
>>= \cacheDir -> (cacheDir </>) <$> urlBaseName path
|
||||
headers <-
|
||||
handleIO (\_ -> pure mempty)
|
||||
$ liftE
|
||||
$ ( catchAllE
|
||||
(\_ ->
|
||||
pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
|
||||
)
|
||||
$ getHead uri'
|
||||
)
|
||||
let mModT = parseModifiedHeader headers
|
||||
e <- liftIO $ doesFileExist json_file
|
||||
if e
|
||||
then do
|
||||
case mModT of
|
||||
Just modTime -> do
|
||||
fileMod <- liftIO $ getModificationTime json_file
|
||||
if modTime > fileMod
|
||||
then do
|
||||
bs <- liftE $ downloadBS uri'
|
||||
liftIO $ writeFileWithModTime modTime json_file bs
|
||||
pure bs
|
||||
else liftIO $ readFile json_file
|
||||
Nothing -> do
|
||||
lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
|
||||
liftIO $ deleteFile json_file
|
||||
liftE $ downloadBS uri'
|
||||
else do
|
||||
case mModT of
|
||||
Just modTime -> do
|
||||
bs <- liftE $ downloadBS uri'
|
||||
liftIO $ writeFileWithModTime modTime json_file bs
|
||||
pure bs
|
||||
Nothing -> do
|
||||
lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
|
||||
liftE $ downloadBS uri'
|
||||
|
||||
parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
|
||||
parseModifiedHeader headers =
|
||||
(M.lookup (CI.mk [s|Last-Modified|]) headers) >>= \h -> parseTimeM
|
||||
True
|
||||
defaultTimeLocale
|
||||
"%a, %d %b %Y %H:%M:%S %Z"
|
||||
(T.unpack . E.decodeUtf8 $ h)
|
||||
|
||||
writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
|
||||
writeFileWithModTime utctime path content = do
|
||||
let mod_time = utcTimeToPOSIXSeconds utctime
|
||||
writeFileL path (Just newFilePerms) content
|
||||
setModificationTimeHiRes path mod_time
|
||||
|
||||
|
||||
|
||||
getDownloadInfo :: ( MonadLogger m
|
||||
|
|
@ -206,7 +287,6 @@ download dli dest mfn
|
|||
$ reThrowAll DownloadFailed
|
||||
$ downloadInternal True https host fullPath port stepper
|
||||
|
||||
-- TODO: verify md5 during download
|
||||
liftE $ checkDigest dli destFile
|
||||
pure destFile
|
||||
|
||||
|
|
@ -282,13 +362,8 @@ downloadBS uri'
|
|||
scheme = view (uriSchemeL' % schemeBSL') uri'
|
||||
path = view pathL' uri'
|
||||
dl https = do
|
||||
host <-
|
||||
preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
|
||||
?? UnsupportedScheme
|
||||
let port = preview
|
||||
(authorityL' % _Just % authorityPortL' % _Just % portNumberL')
|
||||
uri'
|
||||
liftE $ downloadBS' https host path port
|
||||
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
liftE $ downloadBS' https host' fullPath' port'
|
||||
|
||||
|
||||
-- | Load the result of this download into memory at once.
|
||||
|
|
@ -333,20 +408,12 @@ downloadInternal = go (5 :: Int)
|
|||
|
||||
where
|
||||
go redirs progressBar https host path port consumer = do
|
||||
r <- liftIO $ bracket acquire release' action
|
||||
r <- liftIO $ withConnection' https host port action
|
||||
veitherToExcepts r >>= \case
|
||||
Just r' ->
|
||||
if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
|
||||
Nothing -> pure ()
|
||||
where
|
||||
acquire = case https of
|
||||
True -> do
|
||||
ctx <- baselineContextSSL
|
||||
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
|
||||
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
|
||||
|
||||
release' = closeConnection
|
||||
|
||||
action c = do
|
||||
let q = buildRequest1 $ http GET path
|
||||
|
||||
|
|
@ -392,6 +459,95 @@ downloadInternal = go (5 :: Int)
|
|||
|
||||
|
||||
|
||||
getHead :: (MonadCatch m, MonadIO m)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[ HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, NoLocationHeader
|
||||
, TooManyRedirs
|
||||
]
|
||||
m
|
||||
(M.Map (CI ByteString) ByteString)
|
||||
getHead uri' | scheme == [s|https|] = head' True
|
||||
| scheme == [s|http|] = head' False
|
||||
| otherwise = throwE UnsupportedScheme
|
||||
|
||||
where
|
||||
scheme = view (uriSchemeL' % schemeBSL') uri'
|
||||
head' https = do
|
||||
(_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
liftE $ headInternal https host' fullPath' port'
|
||||
|
||||
|
||||
|
||||
headInternal :: MonadIO m
|
||||
=> Bool -- ^ https?
|
||||
-> ByteString -- ^ host
|
||||
-> ByteString -- ^ path with query
|
||||
-> Maybe Int -- ^ optional port
|
||||
-> Excepts
|
||||
'[ HTTPStatusError
|
||||
, URIParseError
|
||||
, UnsupportedScheme
|
||||
, TooManyRedirs
|
||||
, NoLocationHeader
|
||||
]
|
||||
m
|
||||
(M.Map (CI ByteString) ByteString)
|
||||
headInternal = go (5 :: Int)
|
||||
|
||||
where
|
||||
go redirs https host path port = do
|
||||
r <- liftIO $ withConnection' https host port action
|
||||
veitherToExcepts r >>= \case
|
||||
Left r' ->
|
||||
if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
|
||||
Right hs -> pure hs
|
||||
where
|
||||
|
||||
action c = do
|
||||
let q = buildRequest1 $ http HEAD path
|
||||
|
||||
sendRequest c q emptyBody
|
||||
|
||||
unsafeReceiveResponse
|
||||
c
|
||||
(\r _ -> runE $ do
|
||||
let scode = getStatusCode r
|
||||
if
|
||||
| scode >= 200 && scode < 300 -> do
|
||||
let headers = getHeaderMap r
|
||||
pure $ Right $ headers
|
||||
| scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
|
||||
Just r' -> pure $ Left $ r'
|
||||
Nothing -> throwE NoLocationHeader
|
||||
| otherwise -> throwE $ HTTPStatusError scode
|
||||
)
|
||||
|
||||
followRedirectURL bs = case parseURI strictURIParserOptions bs of
|
||||
Right uri' -> do
|
||||
(https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
|
||||
go (redirs - 1) https' host' fullPath' port'
|
||||
Left e -> throwE e
|
||||
|
||||
|
||||
withConnection' :: Bool
|
||||
-> ByteString
|
||||
-> Maybe Int
|
||||
-> (Connection -> IO a)
|
||||
-> IO a
|
||||
withConnection' https host port action = bracket acquire closeConnection action
|
||||
|
||||
where
|
||||
acquire = case https of
|
||||
True -> do
|
||||
ctx <- baselineContextSSL
|
||||
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
|
||||
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
|
||||
|
||||
|
||||
-- | Extracts from a URI type: (https?, host, path+query, port)
|
||||
uriToQuadruple :: Monad m
|
||||
=> URI
|
||||
|
|
|
|||
|
|
@ -12,6 +12,97 @@ import qualified GHC.Generics as GHC
|
|||
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
--[ Download Tree ]--
|
||||
---------------------
|
||||
|
||||
|
||||
-- | Description of all binary and source downloads. This is a tree
|
||||
-- of nested maps.
|
||||
type GHCupDownloads = Map Tool ToolVersionSpec
|
||||
type ToolVersionSpec = Map Version VersionInfo
|
||||
type ArchitectureSpec = Map Architecture PlatformSpec
|
||||
type PlatformSpec = Map Platform PlatformVersionSpec
|
||||
type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
|
||||
|
||||
|
||||
-- | An installable tool.
|
||||
data Tool = GHC
|
||||
| Cabal
|
||||
| GHCup
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
-- | All necessary information of a tool version, including
|
||||
-- source download and per-architecture downloads.
|
||||
data VersionInfo = VersionInfo
|
||||
{ _viTags :: [Tag] -- ^ version specific tag
|
||||
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
|
||||
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
-- | A tag. These are currently attached to a version of a tool.
|
||||
data Tag = Latest
|
||||
| Recommended
|
||||
deriving (Ord, Eq, Show)
|
||||
|
||||
|
||||
data Architecture = A_64
|
||||
| A_32
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
data Platform = Linux LinuxDistro
|
||||
-- ^ must exit
|
||||
| Darwin
|
||||
-- ^ must exit
|
||||
| FreeBSD
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
data LinuxDistro = Debian
|
||||
| Ubuntu
|
||||
| Mint
|
||||
| Fedora
|
||||
| CentOS
|
||||
| RedHat
|
||||
| Alpine
|
||||
| AmazonLinux
|
||||
-- rolling
|
||||
| Gentoo
|
||||
| Exherbo
|
||||
-- not known
|
||||
| UnknownLinux
|
||||
-- ^ must exit
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
|
||||
-- | An encapsulation of a download. This can be used
|
||||
-- to download, extract and install a tool.
|
||||
data DownloadInfo = DownloadInfo
|
||||
{ _dlUri :: URI
|
||||
, _dlSubdir :: Maybe (Path Rel)
|
||||
, _dlHash :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--[ Others ]--
|
||||
--------------
|
||||
|
||||
|
||||
-- | Where to fetch GHCupDownloads from.
|
||||
data URLSource = GHCupURL
|
||||
| OwnSource URI
|
||||
| OwnSpec GHCupDownloads
|
||||
deriving Show
|
||||
|
||||
|
||||
data Settings = Settings
|
||||
{ cache :: Bool
|
||||
, urlSource :: URLSource
|
||||
|
|
@ -33,61 +124,11 @@ data DebugInfo = DebugInfo
|
|||
|
||||
|
||||
data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
|
||||
| SetGHCMajor -- ^ ghc-x.y
|
||||
| SetGHCMinor -- ^ ghc-x.y.z -- TODO: rename
|
||||
| SetGHC_XY -- ^ ghc-x.y
|
||||
| SetGHC_XYZ -- ^ ghc-x.y.z
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
data Tag = Latest
|
||||
| Recommended
|
||||
deriving (Ord, Eq, Show)
|
||||
|
||||
data VersionInfo = VersionInfo
|
||||
{ _viTags :: [Tag] -- ^ version specific tag
|
||||
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
|
||||
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data DownloadInfo = DownloadInfo
|
||||
{ _dlUri :: URI
|
||||
, _dlSubdir :: Maybe (Path Rel)
|
||||
, _dlHash :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Tool = GHC
|
||||
| Cabal
|
||||
| GHCup
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
data Architecture = A_64
|
||||
| A_32
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
data LinuxDistro = Debian
|
||||
| Ubuntu
|
||||
| Mint
|
||||
| Fedora
|
||||
| CentOS
|
||||
| RedHat
|
||||
| Alpine
|
||||
| AmazonLinux
|
||||
-- rolling
|
||||
| Gentoo
|
||||
| Exherbo
|
||||
-- not known
|
||||
| UnknownLinux
|
||||
-- ^ must exit
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
data Platform = Linux LinuxDistro
|
||||
-- ^ must exit
|
||||
| Darwin
|
||||
-- ^ must exit
|
||||
| FreeBSD
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
data PlatformResult = PlatformResult
|
||||
{ _platform :: Platform
|
||||
, _distroVersion :: Maybe Versioning
|
||||
|
|
@ -101,13 +142,3 @@ data PlatformRequest = PlatformRequest
|
|||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
|
||||
type PlatformSpec = Map Platform PlatformVersionSpec
|
||||
type ArchitectureSpec = Map Architecture PlatformSpec
|
||||
type ToolVersionSpec = Map Version VersionInfo
|
||||
type GHCupDownloads = Map Tool ToolVersionSpec
|
||||
|
||||
data URLSource = GHCupURL
|
||||
| OwnSource URI
|
||||
| OwnSpec GHCupDownloads
|
||||
deriving Show
|
||||
|
|
|
|||
|
|
@ -219,9 +219,9 @@ toProcessError exe args mps = case mps of
|
|||
-- | Convert the String to a ByteString with the current
|
||||
-- system encoding.
|
||||
unsafePathToString :: Path b -> IO FilePath
|
||||
unsafePathToString (Path p) = do
|
||||
unsafePathToString p = do
|
||||
enc <- getLocaleEncoding
|
||||
unsafeUseAsCStringLen p (peekCStringLen enc)
|
||||
unsafeUseAsCStringLen (toFilePath p) (peekCStringLen enc)
|
||||
|
||||
|
||||
-- | Search for a file in the search paths.
|
||||
|
|
|
|||
Loading…
Reference in New Issue