From ef8e3bd94001777942cd93f422e5cf352f42bdd1 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 13 Jul 2020 18:27:21 +0200 Subject: [PATCH] Reduce number of os/dl lookups --- app/ghcup/BrickMain.hs | 32 ++++++++--------- app/ghcup/Main.hs | 82 +++++++++++++++++------------------------- lib/GHCup.hs | 64 +++++++++++---------------------- 3 files changed, 68 insertions(+), 110 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index f47fd64..307f353 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -50,6 +50,7 @@ import qualified Data.Vector as V data AppState = AppState { lr :: LR , dls :: GHCupDownloads + , pfreq :: PlatformRequest } type LR = GenericList String Vector ListResult @@ -154,9 +155,9 @@ eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) = - continue (AppState (listMoveUp lr) dls) + continue (AppState (listMoveUp lr) dls pfreq) eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) = - continue (AppState (listMoveDown lr) dls) + continue (AppState (listMoveDown lr) dls pfreq) eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) = case find (\(c', _, _) -> c' == c) keyHandlers of Nothing -> continue as @@ -178,7 +179,7 @@ withIOAction action as = case listSelectedElement (lr as) of Right _ -> do apps <- (fmap . fmap) (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. }) - getAppState + $ getAppState Nothing (pfreq as) case apps of Right nas -> do putStrLn "Press enter to continue" @@ -219,9 +220,9 @@ install' AppState {..} (_, ListResult {..}) = do (run $ do case lTool of - GHC -> liftE $ installGHCBin dls lVer Nothing - Cabal -> liftE $ installCabalBin dls lVer Nothing - GHCup -> liftE $ upgradeGHCup dls Nothing False $> () + GHC -> liftE $ installGHCBin dls lVer pfreq + Cabal -> liftE $ installCabalBin dls lVer pfreq + GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> () ) >>= \case VRight _ -> pure $ Right () @@ -314,15 +315,15 @@ logger' = unsafePerformIO ) -brickMain :: Settings -> Maybe URI -> LoggerConfig -> IO () -brickMain s muri l = do +brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO () +brickMain s muri l av pfreq' = do writeIORef uri' muri writeIORef settings' s -- logger interpreter writeIORef logger' l let runLogger = myLoggerT l - eApps <- getAppState + eApps <- getAppState (Just av) pfreq' case eApps of Right as -> defaultMain app (selectLatest as) $> () Left e -> do @@ -337,8 +338,8 @@ brickMain s muri l = do $ (listElements lr) -getAppState :: IO (Either String AppState) -getAppState = do +getAppState :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppState) +getAppState mg pfreq' = do muri <- readIORef uri' settings <- readIORef settings' l <- readIORef logger' @@ -348,13 +349,12 @@ getAppState = do runLogger . flip runReaderT settings . runE - @'[JSONError, DownloadFailed, FileDoesNotExistError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] + @'[JSONError, DownloadFailed, FileDoesNotExistError] $ do - (GHCupInfo _ dls) <- liftE - $ getDownloadsF (maybe GHCupURL OwnSource muri) + dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg - lV <- liftE $ listVersions dls Nothing Nothing - pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls) + lV <- lift $ listVersions dls Nothing Nothing pfreq' + pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq') case r of VRight a -> pure $ Right a diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index c03cc8d..0d5a3af 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -915,13 +915,10 @@ Report bugs at |] #if !defined(TAR) , ArchiveResult #endif - , DistroNotFound , FileDoesNotExistError , CopyError - , NoCompatibleArch , NoDownload , NotInstalled - , NoCompatiblePlatform , BuildFailed , TagNotFound , DigestError @@ -946,7 +943,7 @@ Report bugs at |] , TagNotFound ] - let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] + let runListGHC = runLogger let runRm = runLogger . flip runReaderT settings . runE @'[NotInstalled] @@ -965,11 +962,8 @@ Report bugs at |] @'[ AlreadyInstalled , BuildFailed , DigestError - , DistroNotFound , DownloadFailed , GHCupSetError - , NoCompatibleArch - , NoCompatiblePlatform , NoDownload , NotFoundInPATH , PatchFailed @@ -988,10 +982,7 @@ Report bugs at |] , BuildFailed , CopyError , DigestError - , DistroNotFound , DownloadFailed - , NoCompatibleArch - , NoCompatiblePlatform , NoDownload , NotInstalled , PatchFailed @@ -1007,9 +998,6 @@ Report bugs at |] . runResourceT . runE @'[ DigestError - , DistroNotFound - , NoCompatiblePlatform - , NoCompatibleArch , NoDownload , NoUpdate , FileDoesNotExistError @@ -1018,9 +1006,19 @@ Report bugs at |] ] - --------------------------- - -- Getting download info -- - --------------------------- + ---------------------------------------- + -- Getting download and platform info -- + ---------------------------------------- + + pfreq <- ( + runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest + ) >>= \case + VRight r -> pure r + VLeft e -> do + runLogger + ($(logError) [i|Error determining Platform: #{e}|]) + exitWith (ExitFailure 2) + (GHCupInfo treq dls) <- ( runLogger @@ -1035,14 +1033,8 @@ Report bugs at |] runLogger ($(logError) [i|Error fetching download info: #{e}|]) exitWith (ExitFailure 2) - (runLogger - . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ checkForUpdates dls - ) - >>= \case - VRight _ -> pure () - VLeft e -> do - runLogger - ($(logError) [i|Error checking for upgrades: #{e}|]) + runLogger $ checkForUpdates dls pfreq + ----------------------- @@ -1052,7 +1044,7 @@ Report bugs at |] let installGHC InstallOptions{..} = (runInstTool $ do v <- liftE $ fromVersion dls instVer GHC - liftE $ installGHCBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version + liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) -- FIXME: ugly sharing of tool version ) >>= \case VRight _ -> do @@ -1086,7 +1078,7 @@ Report bugs at |] let installCabal InstallOptions{..} = (runInstTool $ do v <- liftE $ fromVersion dls instVer Cabal - liftE $ installCabalBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version + liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) -- FIXME: ugly sharing of tool version ) >>= \case VRight _ -> do @@ -1159,7 +1151,7 @@ Report bugs at |] res <- case optCommand of #if defined(BRICK) - Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig >> pure ExitSuccess + Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess #endif Install (Right iopts) -> do runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|]) @@ -1178,16 +1170,10 @@ Report bugs at |] List (ListOptions {..}) -> (runListGHC $ do - l <- listVersions dls lTool lCriteria - pure l + l <- listVersions dls lTool lCriteria pfreq + liftIO $ printListResult lRawFormat l + pure ExitSuccess ) - >>= \case - VRight r -> do - liftIO $ printListResult lRawFormat r - pure ExitSuccess - VLeft e -> do - runLogger ($(logError) [i|#{e}|]) - pure $ ExitFailure 6 Rm (Right rmopts) -> do runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|]) @@ -1214,6 +1200,7 @@ Report bugs at |] buildConfig patchDir addConfArgs + pfreq ) >>= \case VRight _ -> do @@ -1238,7 +1225,7 @@ Make sure to clean up #{tmpdir} afterwards.|]) Compile (CompileCabal CabalCompileOptions {..}) -> (runCompileCabal $ do - liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir + liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir pfreq ) >>= \case VRight _ -> do @@ -1269,7 +1256,7 @@ Make sure to clean up #{tmpdir} afterwards.|]) bdir <- liftIO $ ghcupBinDir pure (Just (bdir [rel|ghcup|])) - (runUpgrade $ (liftE $ upgradeGHCup dls target force)) >>= \case + (runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case VRight v' -> do let pretty_v = prettyVer v' runLogger $ $(logInfo) @@ -1415,37 +1402,32 @@ printListResult raw lr = do checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m) => GHCupDownloads - -> Excepts - '[ NoCompatiblePlatform - , NoCompatibleArch - , DistroNotFound - ] - m - () -checkForUpdates dls = do + -> PlatformRequest + -> m () +checkForUpdates dls pfreq = do forM_ (getLatest dls GHCup) $ \l -> do (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer when (l > ghc_ver) - $ lift $ $(logWarn) + $ $(logWarn) [i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|] forM_ (getLatest dls GHC) $ \l -> do mghc_ver <- latestInstalled GHC forM mghc_ver $ \ghc_ver -> when (l > ghc_ver) - $ lift $ $(logWarn) + $ $(logWarn) [i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|] forM_ (getLatest dls Cabal) $ \l -> do mcabal_ver <- latestInstalled Cabal forM mcabal_ver $ \cabal_ver -> when (l > cabal_ver) - $ lift $ $(logWarn) + $ $(logWarn) [i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|] where latestInstalled tool = (fmap lVer . lastMay) - <$> (listVersions dls (Just tool) (Just ListInstalled)) + <$> (listVersions dls (Just tool) (Just ListInstalled) pfreq) prettyDebugInfo :: DebugInfo -> String diff --git a/lib/GHCup.hs b/lib/GHCup.hs index e9e7bad..7bc9f1b 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -87,15 +87,12 @@ installGHCBin :: ( MonadFail m ) => GHCupDownloads -> Version - -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform + -> PlatformRequest -> Excepts '[ AlreadyInstalled , BuildFailed , DigestError - , DistroNotFound , DownloadFailed - , NoCompatibleArch - , NoCompatiblePlatform , NoDownload , NotInstalled , UnknownArchive @@ -105,12 +102,11 @@ installGHCBin :: ( MonadFail m ] m () -installGHCBin bDls ver mpfReq = do +installGHCBin bDls ver pfreq@(PlatformRequest {..}) = do let tver = (mkTVer ver) lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] whenM (liftIO $ ghcInstalled tver) $ (throwE $ AlreadyInstalled GHC ver) - pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq -- download (or use cached version) dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls @@ -159,15 +155,12 @@ installCabalBin :: ( MonadMask m ) => GHCupDownloads -> Version - -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform + -> PlatformRequest -> Excepts '[ AlreadyInstalled , CopyError , DigestError - , DistroNotFound , DownloadFailed - , NoCompatibleArch - , NoCompatiblePlatform , NoDownload , NotInstalled , UnknownArchive @@ -177,7 +170,7 @@ installCabalBin :: ( MonadMask m ] m () -installCabalBin bDls ver mpfReq = do +installCabalBin bDls ver pfreq@(PlatformRequest {..}) = do lift $ $(logDebug) [i|Requested to install cabal version #{ver}|] bindir <- liftIO ghcupBinDir @@ -191,8 +184,6 @@ installCabalBin bDls ver mpfReq = do ) $ (throwE $ AlreadyInstalled Cabal ver) - pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq - -- download (or use cached version) dlinfo <- lE $ getDownloadInfo Cabal ver pfreq bDls dl <- liftE $ downloadCached dlinfo Nothing @@ -386,31 +377,25 @@ listVersions :: ( MonadCatch m => GHCupDownloads -> Maybe Tool -> Maybe ListCriteria - -> Excepts - '[ NoCompatiblePlatform - , NoCompatibleArch - , DistroNotFound - ] - m - [ListResult] -listVersions av lt criteria = do - pfreq <- platformRequest + -> PlatformRequest + -> m [ListResult] +listVersions av lt criteria pfreq = do case lt of Just t -> do -- get versions from GHCupDownloads let avTools = availableToolVersions av t - lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult pfreq t) + lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult t) case t of -- append stray GHCs GHC -> do - slr <- lift $ strayGHCs avTools + slr <- strayGHCs avTools pure $ (sort (slr ++ lr)) _ -> pure lr Nothing -> do - ghcvers <- listVersions av (Just GHC) criteria - cabalvers <- listVersions av (Just Cabal) criteria - ghcupvers <- listVersions av (Just GHCup) criteria + ghcvers <- listVersions av (Just GHC) criteria pfreq + cabalvers <- listVersions av (Just Cabal) criteria pfreq + ghcupvers <- listVersions av (Just GHCup) criteria pfreq pure (ghcvers <> cabalvers <> ghcupvers) where @@ -455,8 +440,8 @@ listVersions av lt criteria = do pure Nothing -- NOTE: this are not cross ones, because no bindists - toListResult :: PlatformRequest -> Tool -> (Version, [Tag]) -> IO ListResult - toListResult pfreq t (v, tags) = case t of + toListResult :: Tool -> (Version, [Tag]) -> IO ListResult + toListResult t (v, tags) = case t of GHC -> do let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av let tver = mkTVer v @@ -606,15 +591,13 @@ compileGHC :: ( MonadMask m -> Maybe (Path Abs) -- ^ build config -> Maybe (Path Abs) -- ^ patch directory -> [Text] -- ^ additional args to ./configure + -> PlatformRequest -> Excepts '[ AlreadyInstalled , BuildFailed , DigestError - , DistroNotFound , DownloadFailed , GHCupSetError - , NoCompatibleArch - , NoCompatiblePlatform , NoDownload , NotFoundInPATH , PatchFailed @@ -625,7 +608,7 @@ compileGHC :: ( MonadMask m ] m () -compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs = do +compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|] whenM (liftIO $ ghcInstalled tver) (throwE $ AlreadyInstalled GHC (tver ^. tvVersion)) @@ -639,7 +622,6 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs = do -- unpack tmpUnpack <- lift mkGhcupTmpDir liftE $ unpackToDir tmpUnpack dl - (PlatformRequest {..}) <- liftE $ platformRequest void $ liftIO $ darwinNotarization _rPlatform tmpUnpack bghc <- case bstrap of @@ -787,15 +769,13 @@ compileCabal :: ( MonadReader Settings m -> Either Version (Path Abs) -- ^ version to bootstrap with -> Maybe Int -> Maybe (Path Abs) + -> PlatformRequest -> Excepts '[ AlreadyInstalled , BuildFailed , CopyError , DigestError - , DistroNotFound , DownloadFailed - , NoCompatibleArch - , NoCompatiblePlatform , NoDownload , NotInstalled , PatchFailed @@ -806,7 +786,7 @@ compileCabal :: ( MonadReader Settings m ] m () -compileCabal dls tver bghc jobs patchdir = do +compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|] bindir <- liftIO ghcupBinDir @@ -827,7 +807,6 @@ compileCabal dls tver bghc jobs patchdir = do -- unpack tmpUnpack <- lift mkGhcupTmpDir liftE $ unpackToDir tmpUnpack dl - (PlatformRequest {..}) <- liftE $ platformRequest void $ liftIO $ darwinNotarization _rPlatform tmpUnpack let workdir = maybe id (flip ()) (view dlSubdir dlInfo) $ tmpUnpack @@ -909,23 +888,20 @@ upgradeGHCup :: ( MonadMask m -> Maybe (Path Abs) -- ^ full file destination to write ghcup into -> Bool -- ^ whether to force update regardless -- of currently installed version + -> PlatformRequest -> Excepts '[ CopyError , DigestError - , DistroNotFound , DownloadFailed - , NoCompatibleArch - , NoCompatiblePlatform , NoDownload , NoUpdate ] m Version -upgradeGHCup dls mtarget force = do +upgradeGHCup dls mtarget force pfreq = do lift $ $(logInfo) [i|Upgrading GHCup...|] let latestVer = fromJust $ getLatest dls GHCup when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate - pfreq <- liftE platformRequest dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls tmp <- lift withGHCupTmpDir let fn = [rel|ghcup|]