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

Merge branch 'compile-bindist' into master

Browse Source
This commit is contained in:
Julian Ospald 2020-09-13 13:30:28 +02:00
commit 47838b1bd9
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
5 changed files with 217 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
app/ghcup/Main.hs
View File

@ -207,8 +207,8 @@ opts =
( long "keep" ( long "keep"
<> metavar "<always|errors|never>" <> metavar "<always|errors|never>"
<> help <> help
"Keep build directories? (default: never)" "Keep build directories? (default: errors)"
<> value Never <> value Errors
<> hidden <> hidden
) )
<*> option <*> option
@ -1476,20 +1476,4 @@ GHCup cache directory: #{toFilePath diCacheDir}
Architecture: #{prettyArch diArch} Architecture: #{prettyArch diArch}
Platform: #{prettyPlatform diPlatform} Platform: #{prettyPlatform diPlatform}
Version: #{describe_result}|] Version: #{describe_result}|]
where
prettyArch :: Architecture -> String
prettyArch A_64 = "amd64"
prettyArch A_32 = "i386"
prettyArch A_PowerPC = "PowerPC"
prettyArch A_PowerPC64 = "PowerPC64"
prettyArch A_Sparc = "Sparc"
prettyArch A_Sparc64 = "Sparc64"
prettyArch A_ARM = "ARM"
prettyArch A_ARM64 = "ARM64"
prettyPlatform :: PlatformResult -> String
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
= show plat <> ", " <> show v'
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Nothing }
= show plat

12
cabal.project
View File

@ -8,6 +8,18 @@ source-repository-package
tag: 80a1c5fc07f7226c424250ec17f674cd4d618f42 tag: 80a1c5fc07f7226c424250ec17f674cd4d618f42
subdir: haskus-utils-types subdir: haskus-utils-types
source-repository-package
type: git
location: https://github.com/hasufell/hpath.git
tag: bf6d28cf989b70286e12fecc183d5bbf5454a1a2
subdir: hpath-io
source-repository-package
type: git
location: https://github.com/hasufell/hpath.git
tag: bf6d28cf989b70286e12fecc183d5bbf5454a1a2
subdir: hpath-directory
optimization: 2 optimization: 2
package streamly package streamly

4
ghcup.cabal
View File

@ -94,13 +94,13 @@ common hpath
build-depends: hpath >=0.11 build-depends: hpath >=0.11
common hpath-directory common hpath-directory
build-depends: hpath-directory >=0.14 build-depends: hpath-directory >=0.14.1
common hpath-filepath common hpath-filepath
build-depends: hpath-filepath >=0.10.3 build-depends: hpath-filepath >=0.10.3
common hpath-io common hpath-io
build-depends: hpath-io >=0.14 build-depends: hpath-io >=0.14.1
common hpath-posix common hpath-posix
build-depends: hpath-posix >=0.13.2 build-depends: hpath-posix >=0.13.2

242
lib/GHCup.hs
View File

@ -75,9 +75,12 @@ import Prelude hiding ( abs
import Safe hiding ( at ) import Safe hiding ( at )
import System.IO.Error import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment ) import System.Posix.Env.ByteString ( getEnvironment )
import System.Posix.FilePath ( getSearchPath ) import System.Posix.FilePath ( getSearchPath, takeExtension )
import System.Posix.Files.ByteString import System.Posix.Files.ByteString
import Text.Regex.Posix
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
@ -119,7 +122,7 @@ installGHCBindist :: ( MonadFail m
] ]
m m
() ()
installGHCBindist dlinfo ver (PlatformRequest {..}) = do installGHCBindist dlinfo ver pfreq = do
let tver = (mkTVer ver) let tver = (mkTVer ver)
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (lift $ ghcInstalled tver) whenM (lift $ ghcInstalled tver)
@ -128,42 +131,79 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do
-- download (or use cached version) -- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- prepare paths -- prepare paths
ghcdir <- lift $ ghcupGHCDir tver ghcdir <- lift $ ghcupGHCDir tver
-- the subdir of the archive where we do the work liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver pfreq
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ runBuildAction tmpUnpack (Just ghcdir) (installGHC' workdir ghcdir)
liftE $ postGHCInstall tver liftE $ postGHCInstall tver
where -- | Install a packed GHC distribution. This only deals with unpacking and the GHC
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else. -- build system and nothing else.
installGHC' :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m) installPackedGHC :: ( MonadMask m
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides) , MonadCatch m
-> Path Abs -- ^ Path to install to , MonadReader Settings m
-> Excepts '[ProcessError] m () , MonadThrow m
installGHC' path inst = do , MonadLogger m
lift $ $(logInfo) "Installing GHC (this may take a while)" , MonadIO m
lEM $ execLogged "./configure" )
False => Path Abs -- ^ Path to the packed GHC bindist
(["--prefix=" <> toFilePath inst] ++ alpineArgs) -> Maybe TarDir -- ^ Subdir of the archive
[rel|ghc-configure|] -> Path Abs -- ^ Path to install to
(Just path) -> Version -- ^ The GHC version
Nothing -> PlatformRequest
lEM $ make ["install"] (Just path) -> Excepts
pure () '[ BuildFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
] m ()
installPackedGHC dl msubdir inst ver pfreq@(PlatformRequest {..}) = do
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
(msubdir)
liftE $ runBuildAction tmpUnpack
(Just inst)
(installUnpackedGHC workdir inst ver pfreq)
-- | Install an unpacked GHC distribution. This only deals with the GHC
-- build system and nothing else.
installUnpackedGHC :: ( MonadReader Settings m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> Path Abs -- ^ Path to install to
-> Version -- ^ The GHC version
-> PlatformRequest
-> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver (PlatformRequest {..}) = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ execLogged "./configure"
False
(["--prefix=" <> toFilePath inst] ++ alpineArgs)
[rel|ghc-configure|]
(Just path)
Nothing
lEM $ make ["install"] (Just path)
pure ()
where
alpineArgs alpineArgs
| ver >= [vver|8.2.2|] | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
, Linux Alpine <- _rPlatform = ["--disable-ld-override"] = ["--disable-ld-override"]
| otherwise = [] | otherwise
= []
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the -- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@ -773,45 +813,60 @@ compileGHC :: ( MonadMask m
] ]
m m
() ()
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@(PlatformRequest {..})
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|] = do
whenM (lift $ ghcInstalled tver) lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion)) whenM (lift $ ghcInstalled tver)
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
-- download source tarball -- download source tarball
dlInfo <- dlInfo <-
preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
?? NoDownload ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing dl <- liftE $ downloadCached dlInfo Nothing
-- unpack -- unpack
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
bghc <- case bstrap of bghc <- case bstrap of
Right g -> pure $ Right g Right g -> pure $ Right g
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver) Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo) workdir <- maybe (pure tmpUnpack)
ghcdir <- lift $ ghcupGHCDir tver (liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo)
ghcdir <- lift $ ghcupGHCDir tver
liftE $ runBuildAction (bindist, bmk) <- liftE $ runBuildAction
tmpUnpack tmpUnpack
(Just ghcdir) (Just ghcdir)
(compile bghc ghcdir workdir >> markSrcBuilt ghcdir workdir) (do
b <- compileBindist bghc ghcdir workdir
bmk <- liftIO $ readFileStrict (build_mk workdir)
pure (b, bmk)
)
reThrowAll GHCupSetError $ postGHCInstall tver liftE $ installPackedGHC bindist
pure () (view dlSubdir dlInfo)
ghcdir
(tver ^. tvVersion)
pfreq
liftIO $ writeFile (ghcdir </> ghcUpSrcBuiltFile) (Just newFilePerms) bmk
reThrowAll GHCupSetError $ postGHCInstall tver
pure ()
where where
defaultConf = case _tvTarget tver of defaultConf = case _tvTarget tver of
Nothing -> [s| Nothing -> [s|
V=0 V=0
BUILD_MAN = NO BUILD_MAN = NO
BUILD_SPHINX_HTML = NO BUILD_SPHINX_HTML = NO
BUILD_SPHINX_PDF = NO BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES|] HADDOCK_DOCS = YES|]
Just _ -> [s| Just _ -> [s|
V=0 V=0
BUILD_MAN = NO BUILD_MAN = NO
BUILD_SPHINX_HTML = NO BUILD_SPHINX_HTML = NO
@ -819,23 +874,26 @@ BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = NO HADDOCK_DOCS = NO
Stage1Only = YES|] Stage1Only = YES|]
compile :: (MonadReader Settings m, MonadThrow m, MonadCatch m, MonadLogger m, MonadIO m) compileBindist :: ( MonadReader Settings m
=> Either (Path Rel) (Path Abs) , MonadThrow m
-> Path Abs , MonadCatch m
-> Path Abs , MonadLogger m
-> Excepts , MonadIO m
'[ FileDoesNotExistError , MonadFail m
, InvalidBuildConfig )
, PatchFailed => Either (Path Rel) (Path Abs)
, ProcessError -> Path Abs
, NotFoundInPATH -> Path Abs
] -> Excepts
m '[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
() m
compile bghc ghcdir workdir = do (Path Abs) -- ^ output path of bindist
compileBindist bghc ghcdir workdir = do
lift $ $(logInfo) [i|configuring build|] lift $ $(logInfo) [i|configuring build|]
liftE $ checkBuildConfig liftE $ checkBuildConfig
Settings { dirs = Dirs {..} } <- lift ask
forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
cEnv <- liftIO $ getEnvironment cEnv <- liftIO $ getEnvironment
@ -886,29 +944,49 @@ Stage1Only = YES|]
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
lift $ $(logInfo) [i|Building (this may take a while)...|] lift $ $(logInfo) [i|Building (this may take a while)...|]
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
(Just workdir)
lift $ $(logInfo) [i|Installing...|] lift $ $(logInfo) [i|Creating bindist...|]
lEM $ make ["install"] (Just workdir) lEM $ make ["binary-dist"] (Just workdir)
[tar] <- liftIO $ findFiles
markSrcBuilt ghcdir workdir = do workdir
let dest = (ghcdir </> ghcUpSrcBuiltFile) (makeRegexOpts compExtended
liftIO $ copyFile (build_mk workdir) dest Overwrite execBlank
([s|^ghc-.*\.tar\..*$|] :: ByteString)
)
c <- liftIO $ readFile (workdir </> tar)
cDigest <-
fmap (T.take 8)
. lift
. throwEither
. E.decodeUtf8'
. B16.encode
. SHA256.hashlazy
$ c
tarName <-
parseRel
[i|ghc-#{prettyTVer tver}-#{prettyPfReq pfreq}-#{cDigest}.tar#{takeExtension (toFilePath tar)}|]
let tarPath = cacheDir </> tarName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
tarPath
Strict
lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
pure tarPath
build_mk workdir = workdir </> [rel|mk/build.mk|] build_mk workdir = workdir </> [rel|mk/build.mk|]
checkBuildConfig :: (MonadCatch m, MonadIO m) checkBuildConfig :: (MonadCatch m, MonadIO m)
=> Excepts => Excepts
'[FileDoesNotExistError , InvalidBuildConfig] '[FileDoesNotExistError, InvalidBuildConfig]
m m
() ()
checkBuildConfig = do checkBuildConfig = do
c <- case mbuildConfig of c <- case mbuildConfig of
Just bc -> do Just bc -> do
BL.toStrict <$> liftIOException doesNotExistErrorType BL.toStrict <$> liftIOException
(FileDoesNotExistError $ toFilePath bc) doesNotExistErrorType
(liftIO $ readFile bc) (FileDoesNotExistError $ toFilePath bc)
(liftIO $ readFile bc)
Nothing -> pure defaultConf Nothing -> pure defaultConf
let lines' = fmap T.strip . T.lines $ decUTF8Safe c let lines' = fmap T.strip . T.lines $ decUTF8Safe c

41
lib/GHCup/Types.hs
View File

@ -19,6 +19,7 @@ import Data.Versions
import HPath import HPath
import URI.ByteString import URI.ByteString
import qualified Data.Text as T
import qualified GHC.Generics as GHC import qualified GHC.Generics as GHC
@ -108,6 +109,15 @@ data Architecture = A_64
| A_ARM64 | A_ARM64
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
prettyArch :: Architecture -> String
prettyArch A_64 = "x86_64"
prettyArch A_32 = "i386"
prettyArch A_PowerPC = "powerpc"
prettyArch A_PowerPC64 = "powerpc64"
prettyArch A_Sparc = "sparc"
prettyArch A_Sparc64 = "sparc64"
prettyArch A_ARM = "arm"
prettyArch A_ARM64 = "aarch64"
data Platform = Linux LinuxDistro data Platform = Linux LinuxDistro
-- ^ must exit -- ^ must exit
@ -116,6 +126,11 @@ data Platform = Linux LinuxDistro
| FreeBSD | FreeBSD
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
prettyPlatfrom :: Platform -> String
prettyPlatfrom (Linux distro) = "linux-" ++ prettyDistro distro
prettyPlatfrom Darwin = "darwin"
prettyPlatfrom FreeBSD = "freebsd"
data LinuxDistro = Debian data LinuxDistro = Debian
| Ubuntu | Ubuntu
| Mint | Mint
@ -132,6 +147,19 @@ data LinuxDistro = Debian
-- ^ must exit -- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
prettyDistro :: LinuxDistro -> String
prettyDistro Debian = "debian"
prettyDistro Ubuntu = "ubuntu"
prettyDistro Mint= "mint"
prettyDistro Fedora = "fedora"
prettyDistro CentOS = "centos"
prettyDistro RedHat = "redhat"
prettyDistro Alpine = "alpine"
prettyDistro AmazonLinux = "amazon"
prettyDistro Gentoo = "gentoo"
prettyDistro Exherbo = "exherbo"
prettyDistro UnknownLinux = "unknown"
-- | An encapsulation of a download. This can be used -- | An encapsulation of a download. This can be used
-- to download, extract and install a tool. -- to download, extract and install a tool.
@ -219,6 +247,12 @@ data PlatformResult = PlatformResult
} }
deriving (Eq, Show) deriving (Eq, Show)
prettyPlatform :: PlatformResult -> String
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Just v' }
= show plat <> ", " <> show v'
prettyPlatform PlatformResult { _platform = plat, _distroVersion = Nothing }
= show plat
data PlatformRequest = PlatformRequest data PlatformRequest = PlatformRequest
{ _rArch :: Architecture { _rArch :: Architecture
, _rPlatform :: Platform , _rPlatform :: Platform
@ -226,6 +260,13 @@ data PlatformRequest = PlatformRequest
} }
deriving (Eq, Show) deriving (Eq, Show)
prettyPfReq :: PlatformRequest -> String
prettyPfReq (PlatformRequest arch plat ver) =
prettyArch arch ++ "-" ++ prettyPlatfrom plat ++ pver
where
pver = case ver of
Just v' -> "-" ++ (T.unpack $ prettyV v')
Nothing -> ""
-- | A GHC identified by the target platform triple -- | A GHC identified by the target platform triple
-- and the version. -- and the version.