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

Allow to specify regex for subdir

This commit is contained in:
Julian Ospald 2020-08-06 13:28:20 +02:00
parent cafedd73a2
commit 5c45884f5f
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
10 changed files with 123 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitlab-ci.yml
View File

@ -57,7 +57,7 @@ variables:
script:
- ./.gitlab/script/ghcup_version.sh
variables:
JSON_VERSION: "0.0.2"
JSON_VERSION: "0.0.3"
.test_ghcup_version:linux:
extends:

4
app/ghcup/BrickMain.hs
View File

@ -214,7 +214,9 @@ install' AppState {..} (_, ListResult {..}) = do
, TagNotFound
, DigestError
, DownloadFailed
, NoUpdate]
, NoUpdate
, TarDirDoesNotExist
]
(run $ do
case lTool of

11
app/ghcup/Main.hs
View File

@ -404,7 +404,11 @@ installParser =
installGHCFooter = [s|Discussion:
Installs the specified GHC version (or a recommended default one) into
a self-contained "~/.ghcup/ghc/<ghcver>" directory
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".|]
and symlinks the ghc binaries to "~/.ghcup/bin/<binary>-<ghcver>".
Examples:
# install GHC head
ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27" }' head|]
installOpts :: Parser InstallOptions
@ -428,7 +432,7 @@ installOpts =
<> long "url"
<> metavar "BINDIST_URL"
<> help
"Provide DownloadInfo as json string, e.g.: '{ \"dlHash\": \"<sha256 hash>\", \"dlSubdir\": \"ghc-<ver>\", \"dlUri\": \"<uri>\" }'"
"Provide DownloadInfo as json string, e.g.: '{ \"dlHash\": \"<sha256 hash>\", \"dlSubdir\": { \"RegexDir\": \"ghc-.*\"}, \"dlUri\": \"<uri>\" }'"
)
)
)
@ -940,6 +944,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TagNotFound
, DigestError
, DownloadFailed
, TarDirDoesNotExist
]
let
@ -986,6 +991,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@ -1005,6 +1011,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NotInstalled
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif

4
ghcup.cabal
View File

@ -153,6 +153,9 @@ common safe
common safe-exceptions
build-depends: safe-exceptions >=0.1
common split
build-depends: split >=0.2.3.4
common streamly
build-depends: streamly >=0.7.1
@ -276,6 +279,7 @@ library
, resourcet
, safe
, safe-exceptions
, split
, streamly
, streamly-posix
, streamly-bytestring

95
lib/GHCup.hs
View File

@ -112,6 +112,7 @@ installGHCBindist :: ( MonadFail m
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@ -136,7 +137,7 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do
ghcdir <- lift $ ghcupGHCDir tver
-- the subdir of the archive where we do the work
let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ runBuildAction tmpUnpack (Just ghcdir) (installGHC' workdir ghcdir)
@ -189,6 +190,7 @@ installGHCBin :: ( MonadFail m
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@ -221,6 +223,7 @@ installCabalBindist :: ( MonadMask m
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@ -250,7 +253,7 @@ installCabalBindist dlinfo ver (PlatformRequest {..}) = do
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
let workdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
liftE $ installCabal' workdir binDir
@ -300,6 +303,7 @@ installCabalBin :: ( MonadMask m
, NoDownload
, NotInstalled
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@ -328,16 +332,22 @@ installCabalBin bDls ver pfreq = do
--
-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@
-- for 'SetGHCOnly' constructor.
setGHC :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
setGHC :: ( MonadReader Settings m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadCatch m
)
=> GHCTargetVersion
-> SetGHC
-> Excepts '[NotInstalled] m GHCTargetVersion
setGHC ver sghc = do
let verBS = verToBS (_tvVersion ver)
ghcdir <- lift $ ghcupGHCDir ver
ghcdir <- lift $ ghcupGHCDir ver
-- symlink destination
Settings {dirs = Dirs {..}} <- lift ask
Settings { dirs = Dirs {..} } <- lift ask
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms binDir
-- first delete the old symlinks (this fixes compatibility issues
@ -350,19 +360,26 @@ setGHC ver sghc = do
-- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver
forM_ verfiles $ \file -> do
targetFile <- case sghc of
SetGHCOnly -> pure file
mTargetFile <- case sghc of
SetGHCOnly -> pure $ Just file
SetGHC_XY -> do
major' <- (\(mj, mi) -> E.encodeUtf8 $ intToText mj <> "." <> intToText mi)
<$> getMajorMinorV (_tvVersion ver)
parseRel (toFilePath file <> B.singleton _hyphen <> major')
SetGHC_XYZ -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
v' <-
handle
(\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
$ fmap Just
$ getMajorMinorV (_tvVersion ver)
forM v' $ \(mj, mi) ->
let major' = E.encodeUtf8 $ intToText mj <> "." <> intToText mi
in parseRel (toFilePath file <> B.singleton _hyphen <> major')
SetGHC_XYZ ->
fmap Just $ parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
-- create symlink
let fullF = binDir </> targetFile
destL <- lift $ ghcLinkDestination (toFilePath file) ver
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
liftIO $ createSymlink fullF destL
forM mTargetFile $ \targetFile -> do
let fullF = binDir </> targetFile
destL <- lift $ ghcLinkDestination (toFilePath file) ver
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
liftIO $ createSymlink fullF destL
-- create symlink for share dir
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verBS
@ -376,7 +393,7 @@ setGHC ver sghc = do
-> ByteString
-> m ()
symlinkShareDir ghcdir verBS = do
Settings {dirs = Dirs {..}} <- ask
Settings { dirs = Dirs {..} } <- ask
let destdir = baseDir
case sghc of
SetGHCOnly -> do
@ -589,7 +606,13 @@ listVersions av lt criteria pfreq = do
-- This may leave GHCup without a "set" version.
-- Will try to fix the ghc-x.y symlink after removal (e.g. to an
-- older version).
rmGHCVer :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m)
rmGHCVer :: ( MonadReader Settings m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadFail m
, MonadCatch m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
rmGHCVer ver = do
@ -614,12 +637,17 @@ rmGHCVer ver = do
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
-- first remove
lift $ rmMajorSymlinks ver
handle (\(_ :: ParseError) -> pure ()) $ lift $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version)
(mj, mi) <- getMajorMinorV (_tvVersion ver)
lift (getGHCForMajor mj mi (_tvTarget ver)) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
v' <-
handle
(\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
$ fmap Just
$ getMajorMinorV (_tvVersion ver)
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
Settings {dirs = Dirs {..}} <- lift ask
Settings { dirs = Dirs {..} } <- lift ask
liftIO
$ hideError doesNotExistErrorType
@ -708,6 +736,7 @@ compileGHC :: ( MonadMask m
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@ -733,7 +762,7 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..}
bghc <- case bstrap of
Right g -> pure $ Right g
Left bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo)
ghcdir <- lift $ ghcupGHCDir tver
liftE $ runBuildAction
@ -888,6 +917,7 @@ compileCabal :: ( MonadReader Settings m
, NotInstalled
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
#if !defined(TAR)
, ArchiveResult
#endif
@ -917,7 +947,7 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
liftE $ unpackToDir tmpUnpack dl
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlInfo)
cbin <- liftE $ runBuildAction tmpUnpack Nothing (compile workdir)
@ -1039,13 +1069,24 @@ upgradeGHCup dls mtarget force pfreq = do
-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for
-- both installing from source and bindist.
postGHCInstall :: (MonadReader Settings m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
postGHCInstall :: ( MonadReader Settings m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadCatch m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
postGHCInstall ver@GHCTargetVersion{..} = do
postGHCInstall ver@GHCTargetVersion {..} = do
void $ liftE $ setGHC ver SetGHC_XYZ
-- Create ghc-x.y symlinks. This may not be the current
-- version, create it regardless.
(mj, mi) <- getMajorMinorV _tvVersion
lift (getGHCForMajor mj mi _tvTarget) >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
v' <-
handle (\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
$ fmap Just
$ getMajorMinorV _tvVersion
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget)
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)

3
lib/GHCup/Errors.hs
View File

@ -89,6 +89,9 @@ data JSONError = JSONDecodeError String
data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show
data TarDirDoesNotExist = TarDirDoesNotExist TarDir
deriving Show
-- | File digest verification failed.
data DigestError = DigestError Text Text
deriving Show

8
lib/GHCup/Types.hs
View File

@ -137,7 +137,7 @@ data LinuxDistro = Debian
-- to download, extract and install a tool.
data DownloadInfo = DownloadInfo
{ _dlUri :: URI
, _dlSubdir :: Maybe (Path Rel)
, _dlSubdir :: Maybe TarDir
, _dlHash :: Text
}
deriving (Eq, Show)
@ -150,6 +150,12 @@ data DownloadInfo = DownloadInfo
--------------
-- | How to descend into a tar archive.
data TarDir = RealDir (Path Rel)
| RegexDir String -- ^ will be compiled to regex, the first match will "win"
deriving (Eq, Show)
-- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL
| OwnSource URI

4
lib/GHCup/Types/JSON.hs
View File

@ -193,3 +193,7 @@ instance FromJSON (Path Rel) where
case parseRel d of
Right x -> pure x
Left e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e
deriveJSON defaultOptions{ sumEncoding = ObjectWithSingleField } ''TarDir

24
lib/GHCup/Utils.hs
View File

@ -48,7 +48,9 @@ import Control.Monad.Logger
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.Either
import Data.Foldable
import Data.List
import Data.List.Split
import Data.Maybe
import Data.String.Interpolate
import Data.Text ( Text )
@ -403,6 +405,28 @@ unpackToDir dest av = do
| otherwise -> throwE $ UnknownArchive fn
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
=> Path Abs -- ^ unpacked tar dir
-> TarDir -- ^ how to descend
-> Excepts '[TarDirDoesNotExist] m (Path Abs)
intoSubdir bdir tardir = case tardir of
RealDir pr -> do
whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))
(throwE $ TarDirDoesNotExist tardir)
pure (bdir </> pr)
RegexDir r -> do
let rs = splitOn "/" r
foldlM
(\y x ->
(fmap sort . handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= \case
[] -> throwE $ TarDirDoesNotExist tardir
(p : _) -> pure (y </> p)
)
bdir
rs
where regex = makeRegexOpts compIgnoreCase execBlank
------------

1
lib/GHCup/Utils/Dirs.hs
View File

@ -166,7 +166,6 @@ ghcupGHCDir :: (MonadReader Settings m, MonadThrow m)
=> GHCTargetVersion
-> m (Path Abs)
ghcupGHCDir ver = do
Settings {..} <- ask
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel $ E.encodeUtf8 (prettyTVer ver)
pure (ghcbasedir </> verdir)