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

Allow to install haskell-language-server wrt #65

Browse Source
This commit is contained in:
Julian Ospald
2020-09-20 17:57:16 +02:00
parent b2027f1625
commit bb7c4205db
11 changed files with 10506 additions and 8462 deletions
Download Patch File Download Diff File Expand all files Collapse all files

261
lib/GHCup.hs
View File

@@ -357,6 +357,130 @@ installCabalBin bDls ver pfreq = do
installCabalBindist dlinfo ver pfreq
-- | Like 'installHLSBin, except takes the 'DownloadInfo' as
-- argument instead of looking it up from 'GHCupDownloads'.
installHLSBindist :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
, MonadFail m
)
=> DownloadInfo
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installHLSBindist dlinfo ver (PlatformRequest {..}) = do
lift $ $(logDebug) [i|Requested to install hls version #{ver}|]
Settings {dirs = Dirs {..}} <- lift ask
whenM (lift (hlsInstalled ver))
$ (throwE $ AlreadyInstalled HLS ver)
-- download (or use cached version)
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift withGHCupTmpDir
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) (view dlSubdir dlinfo)
liftE $ installHLS' workdir binDir
-- create symlink if this is the latest version
hlsVers <- lift $ fmap rights $ getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
pure ()
where
-- | Install an unpacked hls distribution.
installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked hls bindist (where the executable resides)
-> Path Abs -- ^ Path to install to
-> Excepts '[CopyError] m ()
installHLS' path inst = do
lift $ $(logInfo) "Installing HLS"
liftIO $ createDirRecursive' inst
-- install haskell-language-server-<ghcver>
bins@(_:_) <- liftIO $ findFiles
path
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-[0-9].*$|] :: ByteString)
)
forM_ bins $ \f -> do
toF <- parseRel (toFilePath f <> "~" <> verToBS ver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> f)
(inst </> toF)
Overwrite
lift $ chmod_777 (inst </> toF)
-- install haskell-language-server-wrapper
let wrapper = [rel|haskell-language-server-wrapper|]
toF <- parseRel (toFilePath wrapper <> "-" <> verToBS ver)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> wrapper)
(inst </> toF)
Overwrite
lift $ chmod_777 (inst </> toF)
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
installHLSBin :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
, MonadFail m
)
=> GHCupDownloads
-> Version
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, DownloadFailed
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installHLSBin bDls ver pfreq = do
dlinfo <- lE $ getDownloadInfo HLS ver pfreq bDls
installHLSBindist dlinfo ver pfreq
---------------------
@@ -487,6 +611,55 @@ setCabal ver = do
-- | Set the haskell-language-server symlinks.
setHLS :: ( MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
)
=> Version
-> Excepts '[NotInstalled] m ()
setHLS ver = do
Settings { dirs = Dirs {..} } <- lift ask
liftIO $ createDirRecursive' binDir
-- Delete old symlinks, since these might have different ghc versions than the
-- selected version, so we could end up with stray or incorrect symlinks.
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
liftIO $ deleteFile (binDir </> f)
-- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver
when (bins == []) $ throwE $ NotInstalled HLS (prettyVer ver)
forM_ bins $ \f -> do
let destL = toFilePath f
target <- parseRel . head . B.split _tilde . toFilePath $ f
lift $ $(logDebug) [i|rm -f #{toFilePath (binDir </> target)}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> target)
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath (binDir </> target)}|]
liftIO $ createSymlink (binDir </> target) destL
-- set haskell-language-server-wrapper symlink
let destL = "haskell-language-server-wrapper-" <> verToBS ver
let wrapper = binDir </> [rel|haskell-language-server-wrapper|]
lift $ $(logDebug) [i|rm -f #{toFilePath wrapper}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile wrapper
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath wrapper}|]
liftIO $ createSymlink wrapper destL
pure ()
------------------
@@ -511,6 +684,7 @@ data ListResult = ListResult
, fromSrc :: Bool -- ^ compiled from source
, lStray :: Bool -- ^ not in download info
, lNoBindist :: Bool -- ^ whether the version is available for this platform/arch
, hlsPowered :: Bool
}
deriving (Eq, Ord, Show)
@@ -544,22 +718,25 @@ listVersions av lt criteria pfreq = do
lr <- filter' <$> forM (Map.toList avTools) (toListResult t)
case t of
-- append stray GHCs
GHC -> do
slr <- strayGHCs avTools
pure $ (sort (slr ++ lr))
Cabal -> do
slr <- strayCabals avTools
pure $ (sort (slr ++ lr))
_ -> pure lr
HLS -> do
slr <- strayHLS avTools
pure $ (sort (slr ++ lr))
GHCup -> pure lr
Nothing -> do
ghcvers <- listVersions av (Just GHC) criteria pfreq
cabalvers <- listVersions av (Just Cabal) criteria pfreq
hlsvers <- listVersions av (Just HLS) criteria pfreq
ghcupvers <- listVersions av (Just GHCup) criteria pfreq
pure (ghcvers <> cabalvers <> ghcupvers)
pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers)
where
strayGHCs :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
strayGHCs :: (MonadCatch m, MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
strayGHCs avTools = do
@@ -571,6 +748,7 @@ listVersions av lt criteria pfreq = do
Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) $ hlsGHCVersions
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
@@ -584,6 +762,7 @@ listVersions av lt criteria pfreq = do
Right tver@GHCTargetVersion{ .. } -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem _tvVersion) $ hlsGHCVersions
pure $ Just $ ListResult
{ lTool = GHC
, lVer = _tvVersion
@@ -619,6 +798,35 @@ listVersions av lt criteria pfreq = do
, lStray = maybe True (const False) (Map.lookup ver avTools)
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, ..
}
Left e -> do
$(logWarn)
[i|Could not parse version of stray directory #{toFilePath e}|]
pure Nothing
strayHLS :: (MonadReader Settings m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
strayHLS avTools = do
hlss <- getInstalledHLSs
fmap catMaybes $ forM hlss $ \case
Right ver ->
case Map.lookup ver avTools of
Just _ -> pure Nothing
Nothing -> do
lSet <- fmap (maybe False (== ver)) $ hlsSet
pure $ Just $ ListResult
{ lTool = HLS
, lVer = ver
, lCross = Nothing
, lTag = []
, lInstalled = True
, lStray = maybe True (const False) (Map.lookup ver avTools)
, lNoBindist = False
, fromSrc = False -- actually, we don't know :>
, hlsPowered = False
, ..
}
Left e -> do
@@ -635,6 +843,7 @@ listVersions av lt criteria pfreq = do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem v) $ hlsGHCVersions
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do
let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq av
@@ -646,6 +855,7 @@ listVersions av lt criteria pfreq = do
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
GHCup -> do
@@ -658,6 +868,20 @@ listVersions av lt criteria pfreq = do
, fromSrc = False
, lStray = False
, lNoBindist = False
, hlsPowered = False
, ..
}
HLS -> do
let lNoBindist = isLeft $ getDownloadInfo HLS v pfreq av
lSet <- fmap (maybe False (== v)) $ hlsSet
lInstalled <- hlsInstalled v
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
, lTool = t
, fromSrc = False
, lStray = False
, hlsPowered = False
, ..
}
@@ -749,6 +973,35 @@ rmCabalVer ver = do
(binDir </> [rel|cabal|])
-- | Delete a hls version. Will try to fix the hls symlinks
-- after removal (e.g. setting it to an older version).
rmHLSVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
=> Version
-> Excepts '[NotInstalled] m ()
rmHLSVer ver = do
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (prettyVer ver))
isHlsSet <- lift $ hlsSet
Settings {dirs = Dirs {..}} <- lift ask
bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f)
when (maybe False (== ver) isHlsSet) $ do
-- delete all set symlinks
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
liftIO $ deleteFile (binDir </> f)
-- set latest hls
hlsVers <- lift $ fmap rights $ getInstalledHLSs
case headMay . reverse . sort $ hlsVers of
Just latestver -> setHLS latestver
Nothing -> pure ()
------------------
--[ Debug info ]--

7
lib/GHCup/Errors.hs
View File

@@ -152,3 +152,10 @@ data ParseError = ParseError String
deriving Show
instance Exception ParseError
data UnexpectedListLength = UnexpectedListLength String
deriving Show
instance Exception UnexpectedListLength

1
lib/GHCup/Types.hs
View File

@@ -76,6 +76,7 @@ type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
data Tool = GHC
| Cabal
| GHCup
| HLS
deriving (Eq, GHC.Generic, Ord, Show)

144
lib/GHCup/Utils.hs
View File

@@ -301,6 +301,150 @@ cabalSet = do
-- | Get all installed hls, by matching on
-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
getInstalledHLSs :: (MonadReader Settings m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
getInstalledHLSs = do
Settings { dirs = Dirs {..} } <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
)
vs <- forM bins $ \f ->
case
fmap
version
(fmap decUTF8Safe . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f)
of
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
pure $ vs
-- | Whether the given HLS version is installed.
hlsInstalled :: (MonadIO m, MonadReader Settings m, MonadCatch m) => Version -> m Bool
hlsInstalled ver = do
vers <- fmap rights $ getInstalledHLSs
pure $ elem ver $ vers
-- Return the currently set hls version, if any.
hlsSet :: (MonadReader Settings m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
hlsSet = do
Settings {dirs = Dirs {..}} <- ask
let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
broken <- isBrokenSymlink hlsBin
if broken
then pure Nothing
else do
link <- readSymbolicLink $ toFilePath hlsBin
Just <$> linkVersion link
where
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "haskell-language-server-wrapper-" *> version'
-- | Return the GHC versions the currently selected HLS supports.
hlsGHCVersions :: ( MonadReader Settings m
, MonadIO m
, MonadThrow m
, MonadCatch m
)
=> m [Version]
hlsGHCVersions = do
h <- hlsSet
vers <- forM h $ \h' -> do
bins <- hlsServerBinaries h'
pure $ fmap
(\bin ->
version
. decUTF8Safe
. fromJust
. B.stripPrefix "haskell-language-server-"
. head
. B.split _tilde
. toFilePath
$ bin
)
bins
pure . rights . concat . maybeToList $ vers
-- | Get all server binaries for an hls version, if any.
hlsServerBinaries :: (MonadReader Settings m, MonadIO m)
=> Version
-> m [Path Rel]
hlsServerBinaries ver = do
Settings { dirs = Dirs {..} } <- ask
liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
execBlank
([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> [s|$|] :: ByteString
)
)
-- | Get the wrapper binary for an hls version, if any.
hlsWrapperBinary :: (MonadReader Settings m, MonadThrow m, MonadIO m)
=> Version
-> m (Maybe (Path Rel))
hlsWrapperBinary ver = do
Settings { dirs = Dirs {..} } <- ask
wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts
compExtended
execBlank
([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> [s|$|] :: ByteString
)
)
case wrapper of
[] -> pure $ Nothing
[x] -> pure $ Just x
_ -> throwM $ UnexpectedListLength
"There were multiple hls wrapper binaries for a single version"
-- | Get all binaries for an hls version, if any.
hlsAllBinaries :: (MonadReader Settings m, MonadIO m, MonadThrow m) => Version -> m [Path Rel]
hlsAllBinaries ver = do
hls <- hlsServerBinaries ver
wrapper <- hlsWrapperBinary ver
pure (maybeToList wrapper ++ hls)
-- | Get the active symlinks for hls.
hlsSymlinks :: (MonadReader Settings m, MonadIO m, MonadCatch m) => m [Path Rel]
hlsSymlinks = do
Settings { dirs = Dirs {..} } <- ask
oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
(makeRegexOpts compExtended
execBlank
([s|^haskell-language-server-.*$|] :: ByteString)
)
filterM
( fmap (== SymbolicLink)
. liftIO
. getFileType
. (binDir </>)
)
oldSyms
-----------------------------------------

12
lib/GHCup/Utils/Prelude.hs
View File

@@ -31,11 +31,13 @@ import Data.ByteString ( ByteString )
import Data.String
import Data.Text ( Text )
import Data.Versions
import Data.Word8
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Strict.Maybe as S
import qualified Data.Text as T
@@ -275,3 +277,13 @@ decUTF8Safe = E.decodeUtf8With E.lenientDecode
decUTF8Safe' :: L.ByteString -> Text
decUTF8Safe' = TL.toStrict . TLE.decodeUtf8With E.lenientDecode
-- | Escape a version for use in regex
escapeVerRex :: Version -> ByteString
escapeVerRex = B.pack . go . B.unpack . verToBS
where
go [] = []
go (x : xs) | x == _period = [_backslash, _period] ++ go xs
| otherwise = x : go xs