From f90741f4d38087fac320cc32d1fa76e6b4dd249e Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 19 Sep 2021 21:24:21 +0200 Subject: [PATCH] Implement compiling HLS from source --- .gitlab-ci.yml | 17 ++++ .gitlab/script/ghcup_hls.sh | 51 ++++++++++ app/ghcup/Main.hs | 152 ++++++++++++++++++++++++++++ data/metadata/ghcup-0.0.6.yaml | 4 + data/metadata/ghcup-0.0.7.yaml | 4 + ghcup.cabal | 1 + lib/GHCup.hs | 176 ++++++++++++++++++++++++++++++++- lib/GHCup/Download.hs | 2 +- lib/GHCup/Errors.hs | 8 +- lib/GHCup/Utils.hs | 4 +- 10 files changed, 410 insertions(+), 9 deletions(-) create mode 100755 .gitlab/script/ghcup_hls.sh diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f94db91..c63f2cd 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -263,6 +263,23 @@ test:linux: CABAL_VERSION: "3.4.0.0" needs: [] +test:linux:hls: + stage: test + extends: + - .test_ghcup_version + - .debian + variables: + GHC_VERSION: "8.10.7" + HLS_TARGET_VERSION: "1.4.0" + CABAL_VERSION: "3.6.0.0" + needs: [] + when: manual + allow_failure: true + before_script: + - ./.gitlab/before_script/linux/install_deps.sh + script: + - ./.gitlab/script/ghcup_hls.sh + test:linux:cross-armv7: stage: test extends: diff --git a/.gitlab/script/ghcup_hls.sh b/.gitlab/script/ghcup_hls.sh new file mode 100755 index 0000000..8bf9ace --- /dev/null +++ b/.gitlab/script/ghcup_hls.sh @@ -0,0 +1,51 @@ +#!/bin/sh + +set -eux + +. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env" + +mkdir -p "$CI_PROJECT_DIR"/.local/bin + +CI_PROJECT_DIR=$(pwd) + +ecabal() { + cabal "$@" +} + +eghcup() { + ghcup -v -c -s file://$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml "$@" +} + +git describe --always + +### build + +ecabal update + +ecabal build -w ghc-${GHC_VERSION} +cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup + +### cleanup + +rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup + +### manual cli based testing + +eghcup --numeric-version + +eghcup install ghc ${GHC_VERSION} +eghcup set ghc ${GHC_VERSION} +eghcup install cabal ${CABAL_VERSION} + +cabal --version + +eghcup debug-info + +eghcup compile hls -j $(nproc) -v ${HLS_TARGET_VERSION} ${GHC_VERSION} + +[ `$(eghcup whereis hls ${HLS_TARGET_VERSION}) --numeric-version` = "${HLS_TARGET_VERSION}" ] || [ `$(eghcup whereis hls ${HLS_TARGET_VERSION}) --numeric-version | sed 's/.0$//'` = "${HLS_TARGET_VERSION}" ] + +# nuke +eghcup nuke +[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ] + diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 0ed292a..e9a8949 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -187,6 +187,7 @@ data RmOptions = RmOptions data CompileCommand = CompileGHC GHCCompileOptions + | CompileHLS HLSCompileOptions data ConfigCommand = ShowConfig | SetConfig String String | InitConfig @@ -205,6 +206,16 @@ data GHCCompileOptions = GHCCompileOptions , isolateDir :: Maybe FilePath } +data HLSCompileOptions = HLSCompileOptions + { targetHLS :: Either Version GitBranch + , jobs :: Maybe Int + , setCompile :: Bool + , ovewrwiteVer :: Maybe Version + , isolateDir :: Maybe FilePath + , cabalProject :: Maybe FilePath + , targetGHCs :: [ToolVersion] + } + data UpgradeOpts = UpgradeInplace | UpgradeAt FilePath | UpgradeGHCupDir @@ -895,6 +906,15 @@ compileP = subparser <> footerDoc (Just $ text compileFooter) ) ) + <> command + "hls" + ( CompileHLS + <$> info + (hlsCompileOpts <**> helper) + ( progDesc "Compile HLS from source" + <> footerDoc (Just $ text compileHLSFooter) + ) + ) ) where compileFooter = [s|Discussion: @@ -919,6 +939,12 @@ Examples: # build cross compiler ghcup compile ghc -j 4 -v 8.4.2 -b 8.2.2 -x armv7-unknown-linux-gnueabihf --config $(pwd)/build.mk -- --enable-unregisterised|] + compileHLSFooter = [s|Discussion: + Compiles and installs the specified HLS version. + +Examples: + ghcup compile hls -v 1.4.0 -j 12 8.10.5 8.10.7 9.0.1|] + configP :: Parser ConfigCommand configP = subparser ( command "init" initP @@ -1188,6 +1214,64 @@ ghcCompileOpts = ) ) +hlsCompileOpts :: Parser HLSCompileOptions +hlsCompileOpts = + HLSCompileOptions + <$> ((Left <$> option + (eitherReader + (first (const "Not a valid version") . version . T.pack) + ) + (short 'v' <> long "version" <> metavar "VERSION" <> help + "The tool version to compile" + ) + ) <|> + (Right <$> (GitBranch <$> option + str + (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help + "The git commit/branch/ref to build from" + ) <*> + optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)")) + ))) + <*> optional + (option + (eitherReader (readEither @Int)) + (short 'j' <> long "jobs" <> metavar "JOBS" <> help + "How many jobs to use for make" + ) + ) + <*> flag + False + True + (long "set" <> help + "Set as active version after install" + ) + <*> optional + (option + (eitherReader + (first (const "Not a valid version") . version . T.pack) + ) + (short 'o' <> long "overwrite-version" <> metavar "OVERWRITE_VERSION" <> help + "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'" + ) + ) + <*> optional + (option + (eitherReader isolateParser) + ( short 'i' + <> long "isolate" + <> metavar "DIR" + <> help "install in an isolated directory instead of the default one, no symlinks to this installation will be made" + ) + ) + <*> optional + (option + str + (short 'p' <> long "projectfile" <> metavar "CABAL_PROJECT_LOCAL" <> help + "Absolute path to a cabal.project.local to be used for the build" + ) + ) + <*> many (toolVersionArgument Nothing (Just GHC)) + toolVersionParser :: Parser ToolVersion toolVersionParser = verP' <|> toolP @@ -1789,6 +1873,29 @@ Report bugs at |] , ArchiveResult ] + let runCompileHLS = + runAppState + . runResourceT + . runE + @'[ AlreadyInstalled + , BuildFailed + , DigestError + , GPGError + , DownloadFailed + , GHCupSetError + , NoDownload + , NotFoundInPATH + , PatchFailed + , UnknownArchive + , TarDirDoesNotExist + , TagNotFound + , NextVerNotFound + , NoToolVersionSet + , NotInstalled + , DirNotEmpty + , ArchiveResult + ] + let runLeanWhereIs = -- Don't use runLeanAppState here, which is disabled on windows. @@ -2224,6 +2331,51 @@ Report bugs at |] runLogger $ logError $ T.pack $ prettyShow e pure $ ExitFailure 8 + Compile (CompileHLS HLSCompileOptions { .. }) -> do + runCompileHLS (do + case targetHLS of + Left targetVer -> do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + let vi = getVersionInfo targetVer HLS dls + forM_ (_viPreCompile =<< vi) $ \msg -> do + lift $ logInfo msg + lift $ logInfo + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene + Right _ -> pure () + ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC) + targetVer <- liftE $ compileHLS + targetHLS + ghcs + jobs + ovewrwiteVer + isolateDir + cabalProject + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + let vi = getVersionInfo targetVer HLS dls + when setCompile $ void $ liftE $ + setHLS targetVer + pure (vi, targetVer) + ) + >>= \case + VRight (vi, tv) -> do + runLogger $ logInfo + "HLS successfully compiled and installed" + forM_ (_viPostInstall =<< vi) $ \msg -> + runLogger $ logInfo msg + putStr (T.unpack $ prettyVer tv) + pure ExitSuccess + VLeft err@(V (BuildFailed tmpdir _)) -> do + case keepDirs settings of + Never -> runLogger $ logError $ T.pack $ prettyShow err + _ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <> + "Check the logs at " <> T.pack logsDir <> " and the build directory " + <> T.pack tmpdir <> " for more clues." <> "\n" <> + "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") + pure $ ExitFailure 9 + VLeft e -> do + runLogger $ logError $ T.pack $ prettyShow e + pure $ ExitFailure 9 Compile (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do runLogger $ logError "Hadrian cross compile support is not yet implemented!" pure $ ExitFailure 9 diff --git a/data/metadata/ghcup-0.0.6.yaml b/data/metadata/ghcup-0.0.6.yaml index cddb711..c56bd9a 100644 --- a/data/metadata/ghcup-0.0.6.yaml +++ b/data/metadata/ghcup-0.0.6.yaml @@ -2388,6 +2388,10 @@ ghcupDownloads: - Latest viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#140 viPostInstall: *hls-post-install + viSourceDL: + dlUri: https://downloads.haskell.org/ghcup/src/haskell-language-server/1.4.0/haskell-language-server-1.4.0.tar.gz + dlSubdir: haskell-language-server-1.4.0 + dlHash: c5d7dbf7fae9aa3ed2c1184b49e82d8ac623ca786494ef6602cfe11735d28db0 viArch: A_64: Linux_UnknownLinux: diff --git a/data/metadata/ghcup-0.0.7.yaml b/data/metadata/ghcup-0.0.7.yaml index eccee6d..7c23cbf 100644 --- a/data/metadata/ghcup-0.0.7.yaml +++ b/data/metadata/ghcup-0.0.7.yaml @@ -2449,6 +2449,10 @@ ghcupDownloads: - Latest viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#140 viPostInstall: *hls-post-install + viSourceDL: + dlUri: https://downloads.haskell.org/ghcup/src/haskell-language-server/1.4.0/haskell-language-server-1.4.0.tar.gz + dlSubdir: haskell-language-server-1.4.0 + dlHash: c5d7dbf7fae9aa3ed2c1184b49e82d8ac623ca786494ef6602cfe11735d28db0 viArch: A_64: Linux_UnknownLinux: diff --git a/ghcup.cabal b/ghcup.cabal index bf0b498..92bb7b8 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -100,6 +100,7 @@ library , base16-bytestring >=0.1.1.6 && <1.1 , binary ^>=0.8.6.0 , bytestring ^>=0.10 + , Cabal , case-insensitive ^>=1.2.1.0 , casing ^>=0.1.4.1 , concurrent-output ^>=1.10.11 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 2c04cc8..5b25a09 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -63,6 +63,11 @@ import Data.Text ( Text ) import Data.Time.Clock import Data.Time.Format.ISO8601 import Data.Versions +import Distribution.Types.Version hiding ( Version ) +import Distribution.Types.PackageId +import Distribution.Types.PackageDescription +import Distribution.Types.GenericPackageDescription +import Distribution.PackageDescription.Parsec import GHC.IO.Exception import Haskus.Utils.Variant.Excepts import Language.Haskell.TH @@ -83,6 +88,7 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.List.NonEmpty as NE import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL @@ -264,6 +270,7 @@ installPackedGHC :: ( MonadMask m , HasLog env , MonadIO m , MonadUnliftIO m + , MonadFail m ) => FilePath -- ^ Path to the packed GHC bindist -> Maybe TarDir -- ^ Subdir of the archive @@ -621,10 +628,7 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do Nothing -> do liftE $ installHLSUnpacked workdir binDir (Just ver) forceInstall - -- create symlink if this is the latest version in a regular install - hlsVers <- lift $ fmap rights getInstalledHLSs - let lInstHLS = headMay . reverse . sort $ hlsVers - when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver + liftE $ installHLSPostInst isoFilepath ver -- | Install an unpacked hls distribution. @@ -678,6 +682,21 @@ installHLSUnpacked path inst mver' forceInstall = do lift $ chmod_755 destWrapperPath + +installHLSPostInst :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m, MonadCatch m, MonadMask m, MonadFail m, MonadUnliftIO m) + => Maybe FilePath + -> Version + -> Excepts '[NotInstalled] m () +installHLSPostInst isoFilepath ver = + case isoFilepath of + Just _ -> pure () + Nothing -> do + -- create symlink if this is the latest version in a regular install + hlsVers <- lift $ fmap rights getInstalledHLSs + let lInstHLS = headMay . reverse . sort $ hlsVers + when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver + + -- | Installs hls binaries @haskell-language-server-\@ -- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. installHLSBin :: ( MonadMask m @@ -716,6 +735,155 @@ installHLSBin ver isoFilepath forceInstall = do installHLSBindist dlinfo ver isoFilepath forceInstall +compileHLS :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Either Version GitBranch + -> [Version] + -> Maybe Int + -> Maybe Version + -> Maybe FilePath + -> Maybe FilePath + -> Excepts '[ NoDownload + , GPGError + , DownloadFailed + , DigestError + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , BuildFailed + , NotInstalled + ] m Version +compileHLS targetHLS ghcs jobs ov isolateDir cabalProject = do + PlatformRequest { .. } <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + Dirs { .. } <- lift getDirs + + (workdir, tver) <- case targetHLS of + -- unpack from version tarball + Left tver -> do + lift $ logDebug $ "Requested to compile: " <> prettyVer tver + + -- download source tarball + dlInfo <- + preview (ix HLS % ix tver % viSourceDL % _Just) dls + ?? NoDownload + dl <- liftE $ downloadCached dlInfo Nothing + + -- unpack + tmpUnpack <- lift mkGhcupTmpDir + liftE $ unpackToDir tmpUnpack dl + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack + + workdir <- maybe (pure tmpUnpack) + (liftE . intoSubdir tmpUnpack) + (view dlSubdir dlInfo) + + pure (workdir, tver) + + -- clone from git + Right GitBranch{..} -> do + tmpUnpack <- lift mkGhcupTmpDir + let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing + tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do + let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo + lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" + lEM $ git [ "init" ] + lEM $ git [ "remote" + , "add" + , "origin" + , fromString rep ] + + let fetch_args = + [ "fetch" + , "--depth" + , "1" + , "--quiet" + , "origin" + , fromString ref ] + lEM $ git fetch_args + + lEM $ git [ "checkout", "FETCH_HEAD" ] + (Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (tmpUnpack "haskell-language-server.cabal")) + pure . (\c -> Version Nothing c [] Nothing) + . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral) + . versionNumbers + . pkgVersion + . package + . packageDescription + $ gpd + + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack + lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver + + pure (tmpUnpack, tver) + + -- the version that's installed may differ from the + -- compiled version, so the user can overwrite it + let installVer = fromMaybe tver ov + + liftE $ runBuildAction + workdir + Nothing + (reThrowAll @_ @'[ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do + let installDir = workdir "out" + + artifacts <- forM (sort ghcs) $ \ghc -> do + let ghcInstallDir = installDir T.unpack (prettyVer ghc) + liftIO $ createDirRecursive' installDir + forM_ cabalProject $ \cp -> handleIO (throwE . CopyError . show) $ liftIO $ copyFile cp (workdir "cabal.project.local") + lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc + liftE $ lEM @_ @'[ProcessError] $ + execLogged "cabal" ( [ "v2-install" + , "-w" + , "ghc-" <> T.unpack (prettyVer ghc) + , "--install-method=copy" + ] ++ + maybe [] (\j -> ["--jobs=" <> show j]) jobs ++ + [ "--overwrite-policy=always" + , "--disable-profiling" + , "--disable-tests" + , "--enable-split-sections" + , "--enable-executable-stripping" + , "--enable-executable-static" + , "--installdir=" <> ghcInstallDir + , "exe:haskell-language-server" + , "exe:haskell-language-server-wrapper"] + ) + (Just workdir) "cabal" Nothing + pure ghcInstallDir + + forM_ artifacts $ \artifact -> do + liftIO $ renameFile (artifact "haskell-language-server" <.> exeExt) + (installDir "haskell-language-server-" <> takeFileName artifact <.> exeExt) + liftIO $ renameFile (artifact "haskell-language-server-wrapper" <.> exeExt) + (installDir "haskell-language-server-wrapper" <.> exeExt) + liftIO $ rmPathForcibly artifact + + case isolateDir of + Just isoDir -> do + lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir + liftE $ installHLSUnpacked installDir isoDir Nothing True + Nothing -> do + liftE $ installHLSUnpacked installDir binDir (Just installVer) True + ) + + liftE $ installHLSPostInst isolateDir installVer + + pure installVer + + + -- | Installs stack into @~\/.ghcup\/bin/stack-\@ and -- creates a default @stack -> stack-x.y.z.q@ symlink for -- the latest installed version. diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index a8e64e8..3cc22cd 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -636,7 +636,7 @@ checkDigest eDigest file = do lift $ logInfo $ "verifying digest of: " <> T.pack p' c <- liftIO $ L.readFile file cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c - when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest) + when ((cDigest /= eDigest) && verify) $ throwE (DigestError file cDigest eDigest) -- | Get additional curl args from env. This is an undocumented option. diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index cd58ce2..ee840a0 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -188,12 +188,14 @@ instance Pretty TarDirDoesNotExist where text "Tar directory does not exist:" <+> pPrint dir -- | File digest verification failed. -data DigestError = DigestError Text Text +data DigestError = DigestError FilePath Text Text deriving Show instance Pretty DigestError where - pPrint (DigestError currentDigest expectedDigest) = - text "Digest error: expected" <+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest + pPrint (DigestError fp currentDigest expectedDigest) = + text "Digest error for" <+> text (fp <> ": expected") + <+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest <+> text + "\nConsider removing the file in case it's cached and try again." -- | File digest verification failed. data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 655b8b7..6546e5d 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -842,6 +842,8 @@ runBuildAction :: ( Pretty (V e) , MonadMask m , HasLog env , MonadUnliftIO m + , MonadFail m + , MonadCatch m ) => FilePath -- ^ build directory (cleaned up depending on Settings) -> Maybe FilePath -- ^ dir to *always* clean up on exception @@ -1039,7 +1041,7 @@ ensureGlobalTools = do shimDownload <- liftE $ lE @_ @'[NoDownload] $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools let dl = downloadCached' shimDownload (Just "gs.exe") Nothing - void $ (\(DigestError _ _) -> do + void $ (\(DigestError _ _ _) -> do lift $ logWarn "Digest doesn't match, redownloading gs.exe..." lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs "gs.exe")) lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs "gs.exe")