Create bindists when compiling GHC wrt #51

2020-09-12 16:41:17 +02:00 · 2020-09-12 16:41:17 +02:00 · 02b360e2a9
commit 02b360e2a9
parent c10ab15e0c
5 changed files with 217 additions and 102 deletions
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@ -207,8 +207,8 @@ opts =
          (  long "keep"
          <> metavar "<always|errors|never>"
          <> help
-               "Keep build directories? (default: never)"
-          <> value Never
+               "Keep build directories? (default: errors)"
+          <> value Errors
          <> hidden
          )
    <*> option
@ -1476,20 +1476,4 @@ GHCup cache directory: #{toFilePath diCacheDir}
 Architecture: #{prettyArch diArch}
 Platform: #{prettyPlatform diPlatform}
 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

--- a/cabal.project
+++ b/cabal.project
@ -8,6 +8,18 @@ source-repository-package
    tag: 80a1c5fc07f7226c424250ec17f674cd4d618f42
    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

 package streamly
--- a/ghcup.cabal
+++ b/ghcup.cabal
@ -94,13 +94,13 @@ common hpath
  build-depends: hpath >=0.11

 common hpath-directory
-  build-depends: hpath-directory >=0.14
+  build-depends: hpath-directory >=0.14.1

 common hpath-filepath
  build-depends: hpath-filepath >=0.10.3

 common hpath-io
-  build-depends: hpath-io >=0.14
+  build-depends: hpath-io >=0.14.1

 common hpath-posix
  build-depends: hpath-posix >=0.13.2
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@ -75,9 +75,12 @@ import           Prelude                 hiding ( abs
 import           Safe                    hiding ( at )
 import           System.IO.Error
 import           System.Posix.Env.ByteString    ( getEnvironment )
-import           System.Posix.FilePath          ( getSearchPath )
+import           System.Posix.FilePath          ( getSearchPath, takeExtension )
 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.Lazy          as BL
 import qualified Data.Map.Strict               as Map
@ -119,7 +122,7 @@ installGHCBindist :: ( MonadFail m
                        ]
                       m
                       ()
-installGHCBindist dlinfo ver (PlatformRequest {..}) = do
+installGHCBindist dlinfo ver pfreq = do
  let tver = (mkTVer ver)
  lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
  whenM (lift $ ghcInstalled tver)
@ -128,42 +131,79 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do
  -- download (or use cached version)
  dl                           <- liftE $ downloadCached dlinfo Nothing

-  -- unpack
-  tmpUnpack                    <- lift mkGhcupTmpDir
-  liftE $ unpackToDir tmpUnpack dl
-  void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-
  -- prepare paths
  ghcdir <- lift $ ghcupGHCDir tver

-  -- the subdir of the archive where we do the work
-  workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
-
-  liftE $ runBuildAction tmpUnpack (Just ghcdir) (installGHC' workdir ghcdir)
+  liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver pfreq

  liftE $ postGHCInstall tver

- where
-  -- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
-  installGHC' :: (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
-              -> Excepts '[ProcessError] m ()
-  installGHC' path inst = 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 ()
+-- | Install a packed GHC distribution. This only deals with unpacking and the GHC
+-- build system and nothing else.
+installPackedGHC :: ( MonadMask m
+                    , MonadCatch m
+                    , MonadReader Settings m
+                    , MonadThrow m
+                    , MonadLogger m
+                    , MonadIO m
+                    )
+                 => Path Abs          -- ^ Path to the packed GHC bindist
+                 -> Maybe TarDir      -- ^ Subdir of the archive
+                 -> Path Abs          -- ^ Path to install to
+                 -> Version           -- ^ The GHC version
+                 -> PlatformRequest
+                 -> Excepts
+                      '[ 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
-    | ver >= [vver|8.2.2|]
-    , Linux Alpine <- _rPlatform = ["--disable-ld-override"]
-    | otherwise = []
+    | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
+    = ["--disable-ld-override"]
+    | otherwise
+    = []


 -- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@ -773,45 +813,60 @@ compileGHC :: ( MonadMask m
                 ]
                m
                ()
-compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do
-  lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
-  whenM (lift $ ghcInstalled tver)
-        (throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
+compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs pfreq@(PlatformRequest {..})
+  = do
+    lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
+    whenM (lift $ ghcInstalled tver)
+          (throwE $ AlreadyInstalled GHC (tver ^. tvVersion))

-  -- download source tarball
-  dlInfo <-
-    preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
-      ?? NoDownload
-  dl        <- liftE $ downloadCached dlInfo Nothing
+    -- download source tarball
+    dlInfo <-
+      preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls
+        ?? NoDownload
+    dl        <- liftE $ downloadCached dlInfo Nothing

-  -- unpack
-  tmpUnpack <- lift mkGhcupTmpDir
-  liftE $ unpackToDir tmpUnpack dl
-  void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
+    -- unpack
+    tmpUnpack <- lift mkGhcupTmpDir
+    liftE $ unpackToDir tmpUnpack dl
+    void $ liftIO $ darwinNotarization _rPlatform tmpUnpack

-  bghc <- case bstrap of
-    Right g    -> pure $ Right g
-    Left  bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
-  workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo)
-  ghcdir <- lift $ ghcupGHCDir tver
+    bghc <- case bstrap of
+      Right g    -> pure $ Right g
+      Left  bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
+    workdir <- maybe (pure tmpUnpack)
+                     (liftE . intoSubdir tmpUnpack)
+                     (view dlSubdir dlInfo)
+    ghcdir         <- lift $ ghcupGHCDir tver

-  liftE $ runBuildAction
-    tmpUnpack
-    (Just ghcdir)
-    (compile bghc ghcdir workdir >> markSrcBuilt ghcdir workdir)
+    (bindist, bmk) <- liftE $ runBuildAction
+      tmpUnpack
+      (Just ghcdir)
+      (do
+        b   <- compileBindist bghc ghcdir workdir
+        bmk <- liftIO $ readFileStrict (build_mk workdir)
+        pure (b, bmk)
+      )

-  reThrowAll GHCupSetError $ postGHCInstall tver
-  pure ()
+    liftE $ installPackedGHC bindist
+                             (view dlSubdir dlInfo)
+                             ghcdir
+                             (tver ^. tvVersion)
+                             pfreq
+
+    liftIO $ writeFile (ghcdir </> ghcUpSrcBuiltFile) (Just newFilePerms) bmk
+
+    reThrowAll GHCupSetError $ postGHCInstall tver
+    pure ()

 where
  defaultConf = case _tvTarget tver of
-                  Nothing -> [s|
+    Nothing -> [s|
 V=0
 BUILD_MAN = NO
 BUILD_SPHINX_HTML = NO
 BUILD_SPHINX_PDF = NO
 HADDOCK_DOCS = YES|]
-                  Just _ -> [s|
+    Just _ -> [s|
 V=0
 BUILD_MAN = NO
 BUILD_SPHINX_HTML = NO
@ -819,23 +874,26 @@ BUILD_SPHINX_PDF = NO
 HADDOCK_DOCS = NO
 Stage1Only = YES|]

-  compile :: (MonadReader Settings m, MonadThrow m, MonadCatch m, MonadLogger m, MonadIO m)
-          => Either (Path Rel) (Path Abs)
-          -> Path Abs
-          -> Path Abs
-          -> Excepts
-               '[ FileDoesNotExistError
-                , InvalidBuildConfig
-                , PatchFailed
-                , ProcessError
-                , NotFoundInPATH
-                ]
-               m
-               ()
-  compile bghc ghcdir workdir = do
+  compileBindist :: ( MonadReader Settings m
+                    , MonadThrow m
+                    , MonadCatch m
+                    , MonadLogger m
+                    , MonadIO m
+                    , MonadFail m
+                    )
+                 => Either (Path Rel) (Path Abs)
+                 -> Path Abs
+                 -> Path Abs
+                 -> Excepts
+                      '[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
+                      m
+                      (Path Abs)  -- ^ output path of bindist
+  compileBindist bghc ghcdir workdir = do
    lift $ $(logInfo) [i|configuring build|]
    liftE $ checkBuildConfig

+    Settings { dirs = Dirs {..} } <- lift ask
+
    forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir

    cEnv <- liftIO $ getEnvironment
@ -886,29 +944,49 @@ Stage1Only = YES|]
        liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf

    lift $ $(logInfo) [i|Building (this may take a while)...|]
-    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
-                        (Just workdir)
+    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)

-    lift $ $(logInfo) [i|Installing...|]
-    lEM $ make ["install"] (Just workdir)
-
-  markSrcBuilt ghcdir workdir = do
-    let dest = (ghcdir </> ghcUpSrcBuiltFile)
-    liftIO $ copyFile (build_mk workdir) dest Overwrite
+    lift $ $(logInfo) [i|Creating bindist...|]
+    lEM $ make ["binary-dist"] (Just workdir)
+    [tar] <- liftIO $ findFiles
+      workdir
+      (makeRegexOpts compExtended
+                     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|]

  checkBuildConfig :: (MonadCatch m, MonadIO m)
                   => Excepts
-                        '[FileDoesNotExistError , InvalidBuildConfig]
+                        '[FileDoesNotExistError, InvalidBuildConfig]
                        m
                        ()
  checkBuildConfig = do
    c <- case mbuildConfig of
      Just bc -> do
-        BL.toStrict <$> liftIOException doesNotExistErrorType
-                                        (FileDoesNotExistError $ toFilePath bc)
-                                        (liftIO $ readFile bc)
+        BL.toStrict <$> liftIOException
+          doesNotExistErrorType
+          (FileDoesNotExistError $ toFilePath bc)
+          (liftIO $ readFile bc)
      Nothing -> pure defaultConf
    let lines' = fmap T.strip . T.lines $ decUTF8Safe c

--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@ -19,6 +19,7 @@ import           Data.Versions
 import           HPath
 import           URI.ByteString

+import qualified Data.Text                     as T
 import qualified GHC.Generics                  as GHC


@ -108,6 +109,15 @@ data Architecture = A_64
                  | A_ARM64
  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
              -- ^ must exit
@ -116,6 +126,11 @@ data Platform = Linux LinuxDistro
              | FreeBSD
  deriving (Eq, GHC.Generic, Ord, Show)

+prettyPlatfrom :: Platform -> String
+prettyPlatfrom (Linux distro) = "linux-" ++ prettyDistro distro
+prettyPlatfrom Darwin = "darwin"
+prettyPlatfrom FreeBSD = "freebsd"
+
 data LinuxDistro = Debian
                 | Ubuntu
                 | Mint
@ -132,6 +147,19 @@ data LinuxDistro = Debian
                 -- ^ must exit
  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
 -- to download, extract and install a tool.
@ -219,6 +247,12 @@ data PlatformResult = PlatformResult
  }
  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
  { _rArch     :: Architecture
  , _rPlatform :: Platform
@ -226,6 +260,13 @@ data PlatformRequest = PlatformRequest
  }
  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
 -- and the version.