Allow to build HLS from hackage

2022-07-09 20:27:55 +02:00 · 2022-07-09 20:27:55 +02:00 · 63f22b28d7
commit 63f22b28d7
parent 9a72fa13d5
4 changed files with 116 additions and 34 deletions
--- a/app/ghcup/GHCup/OptParse/Compile.hs
+++ b/app/ghcup/GHCup/OptParse/Compile.hs
@ -78,8 +78,9 @@ data GHCCompileOptions = GHCCompileOptions
  , isolateDir   :: Maybe FilePath
  }

+
 data HLSCompileOptions = HLSCompileOptions
-  { targetHLS    :: Either Version GitBranch
+  { targetHLS    :: HLSVer
  , jobs         :: Maybe Int
  , setCompile   :: Bool
  , ovewrwiteVer :: Either Bool Version
@ -149,10 +150,12 @@ Examples:
  These need to be available in PATH prior to compilation.

 Examples:
-  # compile 1.7.0.0 for ghc 8.10.5 and 8.10.7, passing '--allow-newer' to cabal
+  # compile 1.7.0.0 from hackage for 8.10.7
+  ghcup compile hls --hackage-version 1.7.0.0 --ghc 8.10.7
+  # compile 1.7.0.0 from official source dist for ghc 8.10.5 and 8.10.7, passing '--allow-newer' to cabal
  ghcup compile hls -v 1.7.0.0 -j 12 --ghc 8.10.5 --ghc 8.10.7 -- --allow-newer
-  # compile from master for ghc 9.2.3 and use 'git describe' to name the binary
-  ghcup compile hls -g master --git-describe-version --ghc 9.2.3
+  # compile from master for ghc 9.2.3 using 'git describe' to name the binary and ignore the pinned index state
+  ghcup compile hls -g master --git-describe-version --ghc 9.2.3 -- --index-state=@(date '+%s')
  # compile a specific commit for ghc 9.2.3 and set a specifc version for the binary name
  ghcup compile hls -g a32db0b -o 1.7.0.0-p1 --ghc 9.2.3|]

@ -270,7 +273,7 @@ ghcCompileOpts =
 hlsCompileOpts :: Parser HLSCompileOptions
 hlsCompileOpts =
  HLSCompileOptions
-    <$> ((Left <$> option
+    <$> ((SourceDist <$> option
          (eitherReader
            (first (const "Not a valid version") . version . T.pack)
          )
@ -278,8 +281,9 @@ hlsCompileOpts =
            "The tool version to compile"
            <> (completer $ versionCompleter Nothing HLS)
          )
-          ) <|>
-          (Right <$> (GitBranch <$> option
+          )
+          <|>
+          (GitDist <$> (GitBranch <$> option
          str
          (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
            "The git commit/branch/ref to build from (accepts anything 'git checkout' accepts)"
@ -287,7 +291,28 @@ hlsCompileOpts =
          optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)"
            <> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"])
          ))
-          )))
+          ))
+          <|>
+          (HackageDist <$> (option
+            (eitherReader
+              (first (const "Not a valid version") . version . T.pack)
+            )
+          (long "hackage-version" <> metavar "HACKAGE_VERSION" <> help
+            "The hackage version to compile"
+            <> (completer $ versionCompleter Nothing HLS)
+          )
+          ))
+          <|>
+          (
+           RemoteDist <$> (option
+            (eitherReader uriParser)
+            (long "remote-source-dist" <> metavar "URI" <> help
+              "URI (https/http/file) to a HLS source distribution"
+              <> completer fileUri
+            )
+          )
+          )
+          )
    <*> optional
          (option
            (eitherReader (readEither @Int))
@ -468,7 +493,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
    (CompileHLS HLSCompileOptions { .. }) -> do
      runCompileHLS runAppState (do
        case targetHLS of
-          Left targetVer -> do
+          SourceDist targetVer -> do
            GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
            let vi = getVersionInfo targetVer HLS dls
            forM_ (_viPreCompile =<< vi) $ \msg -> do
@ -476,7 +501,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
              lift $ logInfo
                "...waiting for 5 seconds, you can still abort..."
              liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
-          Right _ -> pure ()
+          _ -> pure ()
        ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC)
        targetVer <- liftE $ compileHLS
                    targetHLS
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@ -342,7 +342,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
    (GHC, ver)   = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver
  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right over }))
    (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver
-  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver }))
+  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = SourceDist tver }))
+    (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver
+  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HackageDist tver }))
    (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver
  alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True
  alreadyInstalling _ _ = pure False
--- a/lib/GHCup/HLS.hs
+++ b/lib/GHCup/HLS.hs
@ -324,7 +324,7 @@ compileHLS :: ( MonadMask m
              , MonadUnliftIO m
              , MonadFail m
              )
-           => Either Version GitBranch
+           => HLSVer
           -> [Version]
           -> Maybe Int
           -> Either Bool Version
@ -349,9 +349,9 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
  Dirs { .. } <- lift getDirs


-  (workdir, tver, git_describe) <- case targetHLS of
+  (workdir, tmpUnpack, tver, git_describe) <- case targetHLS of
    -- unpack from version tarball
-    Left tver -> do
+    SourceDist tver -> do
      lift $ logDebug $ "Requested to compile: " <> prettyVer tver

      -- download source tarball
@ -369,10 +369,47 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
                       (liftE . intoSubdir tmpUnpack)
                       (view dlSubdir dlInfo)

-      pure (workdir, tver, Nothing)
+      pure (workdir, tmpUnpack, tver, Nothing)
+
+    HackageDist tver -> do
+      lift $ logDebug $ "Requested to compile (from hackage): " <> prettyVer tver
+
+      -- download source tarball
+      tmpUnpack <- lift mkGhcupTmpDir
+      let hls = "haskell-language-server-" <> T.unpack (prettyVer tver)
+      reThrowAll @_ @'[ProcessError] DownloadFailed $ do
+        -- unpack
+        lEM $ exec "cabal" ["unpack", hls] (Just $ fromGHCupPath tmpUnpack) Nothing
+
+      let workdir = appendGHCupPath tmpUnpack hls
+
+      pure (workdir, tmpUnpack, tver, Nothing)
+
+    RemoteDist uri -> do
+      lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)
+
+      -- download source tarball
+      tmpDownload <- lift withGHCupTmpDir
+      tmpUnpack <- lift mkGhcupTmpDir
+      tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
+      (cf, tver) <- liftE $ cleanUpOnError tmpUnpack $ do
+        unpackToDir (fromGHCupPath tmpUnpack) tar
+        let regex = [s|haskell-language-server\.cabal$|] :: B.ByteString
+        [cabalFile] <- liftIO $ handleIO (\_ -> pure []) $ findFilesDeep
+          tmpUnpack
+          (makeRegexOpts compExtended
+                         execBlank
+                         regex
+          )
+        tver <- getCabalVersion (fromGHCupPath tmpUnpack </> cabalFile)
+        pure (cabalFile, tver)
+
+      let workdir = appendGHCupPath tmpUnpack (takeDirectory cf)
+
+      pure (workdir, tmpUnpack, tver, Nothing)

    -- clone from git
-    Right GitBranch{..} -> do
+    GitDist GitBranch{..} -> do
      tmpUnpack <- lift mkGhcupTmpDir
      let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
      reThrowAll @_ @'[ProcessError] DownloadFailed $ do
@ -409,15 +446,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
                        then pure Nothing
                        else fmap Just $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack)
        chash <- gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack)
-        (Just gpd) <- parseGenericPackageDescriptionMaybe
-          <$> liftIO (B.readFile (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal"))
-        let tver = (\c -> Version Nothing c [] Nothing)
-                 . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
-                 . versionNumbers
-                 . pkgVersion
-                 . package
-                 . packageDescription
-                 $ gpd
+        tver <- getCabalVersion (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal")

        liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
        lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n  " <>
@ -425,7 +454,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
                                    (if not shallow_clone then "\n  " <> "'git describe' output: " <> fromJust git_describe else mempty) <>
                                    (if isCommitHash ref then mempty else "\n  " <> "commit hash: " <> chash)

-        pure (tmpUnpack, tver, git_describe)
+        pure (tmpUnpack, tmpUnpack, tver, git_describe)

  -- the version that's installed may differ from the
  -- compiled version, so the user can overwrite it
@ -441,7 +470,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
                  Right v -> pure v

  liftE $ runBuildAction
-    workdir
+    tmpUnpack
    (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do
      let tmpInstallDir = fromGHCupPath workdir </> "out"
      liftIO $ createDirRecursive' tmpInstallDir
@ -457,14 +486,22 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
              pure "cabal.project"
          | otherwise -> pure (takeFileName cp)
        Just (Right uri) -> do
-          tmpUnpack <- lift withGHCupTmpDir
-          cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just "cabal.project") False
+          tmpUnpack' <- lift withGHCupTmpDir
+          cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack') (Just "cabal.project") False
          copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
          pure "cabal.project"
-        Nothing -> pure "cabal.project"
+        Nothing
+          | HackageDist _ <- targetHLS -> do
+              liftIO $ B.writeFile (fromGHCupPath workdir </> "cabal.project") "packages: ./"
+              pure "cabal.project"
+          | RemoteDist _ <- targetHLS -> do
+              let cabalFile = fromGHCupPath workdir </> "cabal.project"
+              liftIO $ whenM (not <$> doesFileExist cabalFile) $ B.writeFile cabalFile "packages: ./"
+              pure "cabal.project"
+          | otherwise -> pure "cabal.project"
      forM_ cabalProjectLocal $ \uri -> do
-        tmpUnpack <- lift withGHCupTmpDir
-        cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just (cp <.> "local")) False
+        tmpUnpack' <- lift withGHCupTmpDir
+        cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack') (Just (cp <.> "local")) False
        copyFileE cpl (fromGHCupPath workdir </> cp <.> "local") False
      artifacts <- forM (sort ghcs) $ \ghc -> do
        let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
@ -658,3 +695,19 @@ rmHLSVer ver = do
    case headMay . reverse . sort $ hlsVers of
      Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing
      Nothing        -> pure ()
+
+
+getCabalVersion :: (MonadIO m, MonadFail m) => FilePath -> m Version
+getCabalVersion fp = do
+  contents <- liftIO $ B.readFile fp
+  gpd <- case parseGenericPackageDescriptionMaybe contents of
+           Nothing -> fail $ "could not parse cabal file: " <> fp
+           Just r -> pure r
+  let tver = (\c -> Version Nothing c [] Nothing)
+           . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
+           . versionNumbers
+           . pkgVersion
+           . package
+           . packageDescription
+           $ gpd
+  pure tver
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@ -657,7 +657,9 @@ isSafeDir (GHCupBinDir _)        = False



-
-
+data HLSVer = SourceDist Version
+            | GitDist GitBranch
+            | HackageDist Version
+            | RemoteDist URI