From 06cc967d0833463194695a507e21da11bbde8156 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 1 Jun 2024 22:26:18 +0800 Subject: [PATCH] [WIP] Add dummy healthcheck --- app/ghcup/Main.hs | 7 +- ghcup.cabal | 2 + lib-opt/GHCup/OptParse.hs | 7 ++ lib-opt/GHCup/OptParse/HealthCheck.hs | 126 ++++++++++++++++++++++++++ lib/GHCup.hs | 2 + lib/GHCup/HealthCheck.hs | 76 ++++++++++++++++ 6 files changed, 214 insertions(+), 6 deletions(-) create mode 100644 lib-opt/GHCup/OptParse/HealthCheck.hs create mode 100644 lib/GHCup/HealthCheck.hs diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index fd5fa06f..2868c85e 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -271,13 +271,7 @@ Report bugs at |] pure s' -#if defined(IS_WINDOWS) - -- FIXME: windows needs 'ensureGlobalTools', which requires - -- full appstate - runLeanAppState = runAppState -#else runLeanAppState = flip runReaderT leanAppstate -#endif runAppState action' = do s' <- liftIO appState runReaderT action' s' @@ -311,6 +305,7 @@ Report bugs at |] Nuke -> nuke appState runLogger Prefetch pfCom -> prefetch pfCom runAppState runLogger GC gcOpts -> gc gcOpts runAppState runLogger + HealthCheckCommand hcOpts -> hc hcOpts runLeanAppState runLogger Run runCommand -> run runCommand appState leanAppstate runLogger PrintAppErrors -> putStrLn allHFError >> pure ExitSuccess diff --git a/ghcup.cabal b/ghcup.cabal index 3873442e..5ea9b728 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -116,6 +116,7 @@ library GHCup.Download.Utils GHCup.Errors GHCup.GHC + GHCup.HealthCheck GHCup.HLS GHCup.List GHCup.Platform @@ -279,6 +280,7 @@ library ghcup-optparse GHCup.OptParse.Config GHCup.OptParse.DInfo GHCup.OptParse.GC + GHCup.OptParse.HealthCheck GHCup.OptParse.Install GHCup.OptParse.List GHCup.OptParse.Nuke diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs index aa8cfa03..f132eca4 100644 --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -22,6 +22,7 @@ module GHCup.OptParse ( , module GHCup.OptParse.ChangeLog , module GHCup.OptParse.Prefetch , module GHCup.OptParse.GC + , module GHCup.OptParse.HealthCheck , module GHCup.OptParse.DInfo , module GHCup.OptParse.Nuke , module GHCup.OptParse.ToolRequirements @@ -47,6 +48,7 @@ import GHCup.OptParse.Upgrade import GHCup.OptParse.ChangeLog import GHCup.OptParse.Prefetch import GHCup.OptParse.GC +import GHCup.OptParse.HealthCheck import GHCup.OptParse.DInfo import GHCup.OptParse.ToolRequirements import GHCup.OptParse.Nuke @@ -110,6 +112,7 @@ data Command | GC GCOptions | Run RunOptions | PrintAppErrors + | HealthCheckCommand HealtCheckOptions @@ -303,6 +306,10 @@ com = <> footerDoc ( Just $ text runFooter ) ) ) + <> command + "healthcheck" + (info ((HealthCheckCommand <$> hcP)<**> helper) + (progDesc "Check health of GHCup")) <> commandGroup "Main commands:" ) <|> subparser diff --git a/lib-opt/GHCup/OptParse/HealthCheck.hs b/lib-opt/GHCup/OptParse/HealthCheck.hs new file mode 100644 index 00000000..58601f26 --- /dev/null +++ b/lib-opt/GHCup/OptParse/HealthCheck.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +module GHCup.OptParse.HealthCheck where + + +import GHCup +import GHCup.Errors +import GHCup.Types +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ + +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Functor +import Haskus.Utils.Variant.Excepts +import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) +import System.Exit + +import qualified Data.Text as T +import Control.Exception.Safe (MonadMask) +import Text.PrettyPrint.Annotated.HughesPJClass (prettyShow) + + + + + + --------------- + --[ Options ]-- + --------------- + + +data HealtCheckOptions = HealtCheckOptions + { hcOffline :: Bool + } deriving (Eq, Show) + + + + --------------- + --[ Parsers ]-- + --------------- + + +hcP :: Parser HealtCheckOptions +hcP = + HealtCheckOptions + <$> + switch + (short 'o' <> long "offline" <> help "Only do checks that don't require internet") + + + + -------------- + --[ Footer ]-- + -------------- + + +hcFooter :: String +hcFooter = [s|Discussion: + Performs various health checks. Good for attaching to bug reports.|] + + + + + --------------------------- + --[ Effect interpreters ]-- + --------------------------- + + +type HCEffects = '[ DigestError + , ContentLengthError + , GPGError + , DownloadFailed + , NoDownload + ] + + + +runHC :: MonadUnliftIO m + => (ReaderT LeanAppState m (VEither HCEffects a) -> m (VEither HCEffects a)) + -> Excepts HCEffects (ResourceT (ReaderT LeanAppState m)) a + -> m (VEither HCEffects a) +runHC runLeanAppState = + runLeanAppState + . runResourceT + . runE + @HCEffects + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +hc :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + ) + => HealtCheckOptions + -> (forall a. ReaderT LeanAppState m (VEither HCEffects a) -> m (VEither HCEffects a)) + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +hc HealtCheckOptions{..} runAppState runLogger = runHC runAppState (do + runHealthCheck hcOffline + ) >>= \case + VRight r -> do + liftIO $ print $ prettyShow r + pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyHFError e + pure $ ExitFailure 27 + diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 8f4811ff..448bd816 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -28,12 +28,14 @@ module GHCup ( module GHCup.GHC, module GHCup.HLS, module GHCup.Stack, + module GHCup.HealthCheck, module GHCup.List ) where import GHCup.Cabal import GHCup.GHC hiding ( GHCVer(..) ) +import GHCup.HealthCheck import GHCup.HLS hiding ( HLSVer(..) ) import GHCup.Stack import GHCup.List diff --git a/lib/GHCup/HealthCheck.hs b/lib/GHCup/HealthCheck.hs new file mode 100644 index 00000000..29d0663c --- /dev/null +++ b/lib/GHCup/HealthCheck.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-| +Module : GHCup.HealthCheck +Description : HealthCheck for GHCup +License : LGPL-3.0 +Stability : experimental +Portability : portable +-} +module GHCup.HealthCheck where + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude.Logger +import GHCup.Version + +import Conduit (sourceToList) +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource + hiding ( throwM ) +import Data.ByteString ( ByteString ) +import Data.Either +import Data.List +import Data.Maybe +import Data.Versions hiding ( patch ) +import GHC.IO.Exception +import Haskus.Utils.Variant.Excepts +import Optics +import Text.PrettyPrint.Annotated.HughesPJClass (Pretty, pPrint, text) + + +data HealthCheckResult = HealthCheckResult { + canFetchMetadata :: VEither '[DownloadFailed] () + } deriving (Show) + +instance Pretty HealthCheckResult where + pPrint (HealthCheckResult {..}) = text "" + +runHealthCheck :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadIO m + , MonadMask m + , MonadFail m + , MonadUnliftIO m + ) + => Bool + -> Excepts + '[ DigestError + , ContentLengthError + , GPGError + , DownloadFailed + , NoDownload + ] + m HealthCheckResult +runHealthCheck offline = do + -- TODO: implement + let canFetchMetadata = VRight () + + pure $ HealthCheckResult {..} +