diff --git a/README.md b/README.md index 364759a..5fc22db 100644 --- a/README.md +++ b/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 diff --git a/TODO.md b/TODO.md index 8e0d89c..cb0af02 100644 --- a/TODO.md +++ b/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 diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 970bc37..0047693 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -390,8 +390,6 @@ upgradeOptsP = --- TODO: something better than Show instance for errors - main :: IO () main = do diff --git a/cabal.project.freeze b/cabal.project.freeze index 9610c15..6d9c3b5 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -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, diff --git a/ghcup.cabal b/ghcup.cabal index d2ac512..0f7dcf0 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 52a1bb9..1f8d27e 100644 --- a/lib/GHCup.hs +++ b/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//bin/ghc --- * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc//bin/ghc --- * SetGHCMinor: ~/.ghcup/bin/ghc- -> ~/.ghcup/ghc//bin/ghc +-- * SetGHC_XY: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc//bin/ghc +-- * SetGHC_XYZ: ~/.ghcup/bin/ghc- -> ~/.ghcup/ghc//bin/ghc -- -- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc//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) diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 6ba9245..4e280c6 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -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 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 330eee5..b0b638e 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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 diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 37b9211..7157029 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -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.