diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index fd5fa06f..de12c492 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -311,6 +311,7 @@ Report bugs at |] Nuke -> nuke appState runLogger Prefetch pfCom -> prefetch pfCom runAppState runLogger GC gcOpts -> gc gcOpts runAppState runLogger + HealthCheckCommand hcOpts -> hc hcOpts runAppState 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..c4c08a0c --- /dev/null +++ b/lib-opt/GHCup/OptParse/HealthCheck.hs @@ -0,0 +1,124 @@ +{-# 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) + + + + + + --------------- + --[ 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 AppState m (VEither HCEffects a) -> m (VEither HCEffects a)) + -> Excepts HCEffects (ResourceT (ReaderT AppState m)) a + -> m (VEither HCEffects a) +runHC runAppState = + runAppState + . runResourceT + . runE + @HCEffects + + + + ------------------ + --[ Entrypoint ]-- + ------------------ + + + +hc :: ( Monad m + , MonadMask m + , MonadUnliftIO m + , MonadFail m + ) + => HealtCheckOptions + -> (forall a. ReaderT AppState 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 _ -> do + 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..a5f78e57 --- /dev/null +++ b/lib/GHCup/HealthCheck.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} +{-# 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 + +runHealthCheck :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadIO m + , MonadMask m + , MonadFail m + , MonadUnliftIO m + ) + => Bool + -> Excepts + '[ DigestError + , ContentLengthError + , GPGError + , DownloadFailed + , NoDownload + ] + m () +runHealthCheck offline = do + pure () +