Create bindists when compiling GHC wrt #51

app/ghcup/Main.hs

@@ -207,8 +207,8 @@ opts =
           (  long "keep"
           <> metavar "<always|errors|never>"
           <> help
-               "Keep build directories? (default: never)"
+               "Keep build directories? (default: errors)"
-          <> value Never
+          <> 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
 

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

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

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
+  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
 
- 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
-    | 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
@@ -773,45 +813,60 @@ compileGHC :: ( MonadMask 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
   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)
+  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|]
     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)
+    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|]
 
   checkBuildConfig :: (MonadCatch m, MonadIO m)
                    => Excepts
-                        '[FileDoesNotExistError , InvalidBuildConfig]
+                        '[FileDoesNotExistError, InvalidBuildConfig]
                         m
                         ()
   checkBuildConfig = do
     c <- case mbuildConfig of
       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
     let lines' = fmap T.strip . T.lines $ decUTF8Safe c
 

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.