[WIP] Add dummy healthcheck

app/ghcup/Main.hs

@@ -271,13 +271,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
                 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 <https://github.com/haskell/ghcup-hs/issues>|]
             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
 

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

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

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
+

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

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 {..}
+