Skip to content

Commit 88a5673

Browse files
hasufellhasufell
committed
[WIP] Add dummy healthcheck
1 parent c95d143 commit 88a5673

File tree

6 files changed

+214
-0
lines changed

6 files changed

+214
-0
lines changed

‎app/ghcup/Main.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -326,6 +326,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
326326
Nuke -> nuke appState runLogger
327327
Prefetch pfCom -> prefetch pfCom settings runAppState runLogger
328328
GC gcOpts -> gc gcOpts runAppState runLogger
329+
HealthCheckCommand hcOpts -> hc hcOpts runLeanAppState runLogger
329330
Run runCommand -> run runCommand settings appState leanAppstate runLogger
330331
PrintAppErrors -> putStrLn allHFError >> pure ExitSuccess
331332

‎ghcup.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -150,6 +150,7 @@ library
150150
GHCup.Download.Utils
151151
GHCup.Errors
152152
GHCup.GHC
153+
GHCup.HealthCheck
153154
GHCup.HLS
154155
GHCup.List
155156
GHCup.Platform
@@ -327,6 +328,7 @@ library ghcup-optparse
327328
GHCup.OptParse.Config
328329
GHCup.OptParse.DInfo
329330
GHCup.OptParse.GC
331+
GHCup.OptParse.HealthCheck
330332
GHCup.OptParse.Install
331333
GHCup.OptParse.List
332334
GHCup.OptParse.Nuke

‎lib-opt/GHCup/OptParse.hs

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@ module GHCup.OptParse (
2323
, module GHCup.OptParse.ChangeLog
2424
, module GHCup.OptParse.Prefetch
2525
, module GHCup.OptParse.GC
26+
, module GHCup.OptParse.HealthCheck
2627
, module GHCup.OptParse.DInfo
2728
, module GHCup.OptParse.Nuke
2829
, module GHCup.OptParse.ToolRequirements
@@ -48,6 +49,7 @@ import GHCup.OptParse.Upgrade
4849
import GHCup.OptParse.ChangeLog
4950
import GHCup.OptParse.Prefetch
5051
import GHCup.OptParse.GC
52+
import GHCup.OptParse.HealthCheck
5153
import GHCup.OptParse.DInfo
5254
import GHCup.OptParse.ToolRequirements
5355
import GHCup.OptParse.Nuke
@@ -119,6 +121,7 @@ data Command
119121
| GC GCOptions
120122
| Run RunOptions
121123
| PrintAppErrors
124+
| HealthCheckCommand HealtCheckOptions
122125

123126

124127

@@ -314,6 +317,10 @@ com =
314317
<> footerDoc ( Just $ text runFooter )
315318
)
316319
)
320+
<> command
321+
"healthcheck"
322+
(info ((HealthCheckCommand <$> hcP)<**> helper)
323+
(progDesc "Check health of GHCup"))
317324
<> commandGroup "Main commands:"
318325
)
319326
<|> 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 Data.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 Data.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)