From 5c45884f5ff7d1a4f2f100e96ef0fad6e7ad2a72 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 6 Aug 2020 13:28:20 +0200 Subject: [PATCH] Allow to specify regex for subdir --- .gitlab-ci.yml | 2 +- app/ghcup/BrickMain.hs | 4 +- app/ghcup/Main.hs | 11 ++++- ghcup.cabal | 4 ++ lib/GHCup.hs | 95 +++++++++++++++++++++++++++++------------ lib/GHCup/Errors.hs | 3 ++ lib/GHCup/Types.hs | 8 +++- lib/GHCup/Types/JSON.hs | 4 ++ lib/GHCup/Utils.hs | 24 +++++++++++ lib/GHCup/Utils/Dirs.hs | 1 - 10 files changed, 123 insertions(+), 33 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5495d6d..dcb7c51 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -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: diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index f563ced..b843976 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -214,7 +214,9 @@ install' AppState {..} (_, ListResult {..}) = do , TagNotFound , DigestError , DownloadFailed - , NoUpdate] + , NoUpdate + , TarDirDoesNotExist + ] (run $ do case lTool of diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 7464ae5..9116ae8 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -404,7 +404,11 @@ installParser = installGHCFooter = [s|Discussion: Installs the specified GHC version (or a recommended default one) into a self-contained "~/.ghcup/ghc/" directory - and symlinks the ghc binaries to "~/.ghcup/bin/-".|] + and symlinks the ghc binaries to "~/.ghcup/bin/-". + +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\": \"\", \"dlSubdir\": \"ghc-\", \"dlUri\": \"\" }'" + "Provide DownloadInfo as json string, e.g.: '{ \"dlHash\": \"\", \"dlSubdir\": { \"RegexDir\": \"ghc-.*\"}, \"dlUri\": \"\" }'" ) ) ) @@ -940,6 +944,7 @@ Report bugs at |] , TagNotFound , DigestError , DownloadFailed + , TarDirDoesNotExist ] let @@ -986,6 +991,7 @@ Report bugs at |] , NotFoundInPATH , PatchFailed , UnknownArchive + , TarDirDoesNotExist #if !defined(TAR) , ArchiveResult #endif @@ -1005,6 +1011,7 @@ Report bugs at |] , NotInstalled , PatchFailed , UnknownArchive + , TarDirDoesNotExist #if !defined(TAR) , ArchiveResult #endif diff --git a/ghcup.cabal b/ghcup.cabal index cca484f..4f9c0cd 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 84b993e..0271bc2 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -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\/\\/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) + diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 5f09bfb..fdf54b0 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -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 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 2e8374a..acdd482 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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 diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 1f27bee..1320c5e 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -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 + diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 445b187..e06e876 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -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 + + ------------ diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index 0e72cf8..2704e42 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -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)