Skip to content

Commit 06cc967

Browse files
hasufellhasufell
committed
[WIP] Add dummy healthcheck
1 parent c17fafb commit 06cc967

File tree

6 files changed

+214
-6
lines changed

6 files changed

+214
-6
lines changed

‎app/ghcup/Main.hs‎

Lines changed: 1 addition & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -271,13 +271,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
271271
pure s'
272272

273273

274-
#if defined(IS_WINDOWS)
275-
-- FIXME: windows needs 'ensureGlobalTools', which requires
276-
-- full appstate
277-
runLeanAppState = runAppState
278-
#else
279274
runLeanAppState = flip runReaderT leanAppstate
280-
#endif
281275
runAppState action' = do
282276
s' <- liftIO appState
283277
runReaderT action' s'
@@ -311,6 +305,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
311305
Nuke -> nuke appState runLogger
312306
Prefetch pfCom -> prefetch pfCom runAppState runLogger
313307
GC gcOpts -> gc gcOpts runAppState runLogger
308+
HealthCheckCommand hcOpts -> hc hcOpts runLeanAppState runLogger
314309
Run runCommand -> run runCommand appState leanAppstate runLogger
315310
PrintAppErrors -> putStrLn allHFError >> pure ExitSuccess
316311

‎ghcup.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -116,6 +116,7 @@ library
116116
GHCup.Download.Utils
117117
GHCup.Errors
118118
GHCup.GHC
119+
GHCup.HealthCheck
119120
GHCup.HLS
120121
GHCup.List
121122
GHCup.Platform
@@ -279,6 +280,7 @@ library ghcup-optparse
279280
GHCup.OptParse.Config
280281
GHCup.OptParse.DInfo
281282
GHCup.OptParse.GC
283+
GHCup.OptParse.HealthCheck
282284
GHCup.OptParse.Install
283285
GHCup.OptParse.List
284286
GHCup.OptParse.Nuke

‎lib-opt/GHCup/OptParse.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ module GHCup.OptParse (
2222
, module GHCup.OptParse.ChangeLog
2323
, module GHCup.OptParse.Prefetch
2424
, module GHCup.OptParse.GC
25+
, module GHCup.OptParse.HealthCheck
2526
, module GHCup.OptParse.DInfo
2627
, module GHCup.OptParse.Nuke
2728
, module GHCup.OptParse.ToolRequirements
@@ -47,6 +48,7 @@ import GHCup.OptParse.Upgrade
4748
import GHCup.OptParse.ChangeLog
4849
import GHCup.OptParse.Prefetch
4950
import GHCup.OptParse.GC
51+
import GHCup.OptParse.HealthCheck
5052
import GHCup.OptParse.DInfo
5153
import GHCup.OptParse.ToolRequirements
5254
import GHCup.OptParse.Nuke
@@ -110,6 +112,7 @@ data Command
110112
| GC GCOptions
111113
| Run RunOptions
112114
| PrintAppErrors
115+
| HealthCheckCommand HealtCheckOptions
113116

114117

115118

@@ -303,6 +306,10 @@ com =
303306
<> footerDoc ( Just $ text runFooter )
304307
)
305308
)
309+
<> command
310+
"healthcheck"
311+
(info ((HealthCheckCommand <$> hcP)<**> helper)
312+
(progDesc "Check health of GHCup"))
306313
<> commandGroup "Main commands:"
307314
)
308315
<|> subparser

‎lib-opt/GHCup/OptParse/HealthCheck.hs‎

Lines changed: 126 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,126 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE TypeApplications #-}
4+
{-# LANGUAGE FlexibleContexts #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE TemplateHaskell #-}
7+
{-# LANGUAGE QuasiQuotes #-}
8+
{-# LANGUAGE DuplicateRecordFields #-}
9+
{-# LANGUAGE RankNTypes #-}
10+
11+
module GHCup.OptParse.HealthCheck where
12+
13+
14+
import GHCup
15+
import GHCup.Errors
16+
import GHCup.Types
17+
import GHCup.Prelude.Logger
18+
import GHCup.Prelude.String.QQ
19+
20+
#if !MIN_VERSION_base(4,13,0)
21+
import Control.Monad.Fail ( MonadFail )
22+
#endif
23+
import Control.Monad.Reader
24+
import Control.Monad.Trans.Resource
25+
import Data.Functor
26+
import Haskus.Utils.Variant.Excepts
27+
import Options.Applicative hiding ( style )
28+
import Prelude hiding ( appendFile )
29+
import System.Exit
30+
31+
import qualified Data.Text as T
32+
import Control.Exception.Safe (MonadMask)
33+
import Text.PrettyPrint.Annotated.HughesPJClass (prettyShow)
34+
35+
36+
37+
38+
39+
---------------
40+
--[ Options ]--
41+
---------------
42+
43+
44+
data HealtCheckOptions = HealtCheckOptions
45+
{ hcOffline :: Bool
46+
} deriving (Eq, Show)
47+
48+
49+
50+
---------------
51+
--[ Parsers ]--
52+
---------------
53+
54+
55+
hcP :: Parser HealtCheckOptions
56+
hcP =
57+
HealtCheckOptions
58+
<$>
59+
switch
60+
(short 'o' <> long "offline" <> help "Only do checks that don't require internet")
61+
62+
63+
64+
--------------
65+
--[ Footer ]--
66+
--------------
67+
68+
69+
hcFooter :: String
70+
hcFooter = [s|Discussion:
71+
Performs various health checks. Good for attaching to bug reports.|]
72+
73+
74+
75+
76+
---------------------------
77+
--[ Effect interpreters ]--
78+
---------------------------
79+
80+
81+
type HCEffects = '[ DigestError
82+
, ContentLengthError
83+
, GPGError
84+
, DownloadFailed
85+
, NoDownload
86+
]
87+
88+
89+
90+
runHC :: MonadUnliftIO m
91+
=> (ReaderT LeanAppState m (VEither HCEffects a) -> m (VEither HCEffects a))
92+
-> Excepts HCEffects (ResourceT (ReaderT LeanAppState m)) a
93+
-> m (VEither HCEffects a)
94+
runHC runLeanAppState =
95+
runLeanAppState
96+
. runResourceT
97+
. runE
98+
@HCEffects
99+
100+
101+
102+
------------------
103+
--[ Entrypoint ]--
104+
------------------
105+
106+
107+
108+
hc :: ( Monad m
109+
, MonadMask m
110+
, MonadUnliftIO m
111+
, MonadFail m
112+
)
113+
=> HealtCheckOptions
114+
-> (forall a. ReaderT LeanAppState m (VEither HCEffects a) -> m (VEither HCEffects a))
115+
-> (ReaderT LeanAppState m () -> m ())
116+
-> m ExitCode
117+
hc HealtCheckOptions{..} runAppState runLogger = runHC runAppState (do
118+
runHealthCheck hcOffline
119+
) >>= \case
120+
VRight r -> do
121+
liftIO $ print $ prettyShow r
122+
pure ExitSuccess
123+
VLeft e -> do
124+
runLogger $ logError $ T.pack $ prettyHFError e
125+
pure $ ExitFailure 27
126+

‎lib/GHCup.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,12 +28,14 @@ module GHCup (
2828
module GHCup.GHC,
2929
module GHCup.HLS,
3030
module GHCup.Stack,
31+
module GHCup.HealthCheck,
3132
module GHCup.List
3233
) where
3334

3435

3536
import GHCup.Cabal
3637
import GHCup.GHC hiding ( GHCVer(..) )
38+
import GHCup.HealthCheck
3739
import GHCup.HLS hiding ( HLSVer(..) )
3840
import GHCup.Stack
3941
import GHCup.List

‎lib/GHCup/HealthCheck.hs‎

Lines changed: 76 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,76 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE RecordWildCards #-}
3+
{-# LANGUAGE DataKinds #-}
4+
{-# LANGUAGE FlexibleContexts #-}
5+
{-# LANGUAGE FlexibleInstances #-}
6+
{-# LANGUAGE MultiParamTypeClasses #-}
7+
8+
{-|
9+
Module : GHCup.HealthCheck
10+
Description : HealthCheck for GHCup
11+
License : LGPL-3.0
12+
Stability : experimental
13+
Portability : portable
14+
-}
15+
module GHCup.HealthCheck where
16+
17+
import GHCup.Download
18+
import GHCup.Errors
19+
import GHCup.Types
20+
import GHCup.Types.JSON ( )
21+
import GHCup.Types.Optics
22+
import GHCup.Utils
23+
import GHCup.Prelude.Logger
24+
import GHCup.Version
25+
26+
import Conduit (sourceToList)
27+
import Control.Applicative
28+
import Control.Exception.Safe
29+
import Control.Monad
30+
#if !MIN_VERSION_base(4,13,0)
31+
import Control.Monad.Fail ( MonadFail )
32+
#endif
33+
import Control.Monad.Reader
34+
import Control.Monad.Trans.Resource
35+
hiding ( throwM )
36+
import Data.ByteString ( ByteString )
37+
import Data.Either
38+
import Data.List
39+
import Data.Maybe
40+
import Data.Versions hiding ( patch )
41+
import GHC.IO.Exception
42+
import Haskus.Utils.Variant.Excepts
43+
import Optics
44+
import Text.PrettyPrint.Annotated.HughesPJClass (Pretty, pPrint, text)
45+
46+
47+
data HealthCheckResult = HealthCheckResult {
48+
canFetchMetadata :: VEither '[DownloadFailed] ()
49+
} deriving (Show)
50+
51+
instance Pretty HealthCheckResult where
52+
pPrint (HealthCheckResult {..}) = text ""
53+
54+
runHealthCheck :: ( MonadReader env m
55+
, HasDirs env
56+
, HasLog env
57+
, MonadIO m
58+
, MonadMask m
59+
, MonadFail m
60+
, MonadUnliftIO m
61+
)
62+
=> Bool
63+
-> Excepts
64+
'[ DigestError
65+
, ContentLengthError
66+
, GPGError
67+
, DownloadFailed
68+
, NoDownload
69+
]
70+
m HealthCheckResult
71+
runHealthCheck offline = do
72+
-- TODO: implement
73+
let canFetchMetadata = VRight ()
74+
75+
pure $ HealthCheckResult {..}
76+

0 commit comments

Comments
 (0)