2760991 · obelisk · git.iko.soy

git.iko.soy/obelisk

Fix errors so they can be turned into warnings. And fix layers

cli-app was beginning to learn too much about obelisk layers

commit276099131cc32c00e32075ad04d6601b130d9981 authorJohn Ericson <John.Ericson@Obsidian.Systems> dateWed 17 Oct 2018, 17:51 (8 years ago) parent3fe5a1e

12 files changed+205−109

compare with master

unifiedsplit

lib/cliapp/obelisk-cliapp.cabal+1 lib/cliapp/src/Obelisk/CliApp.hs+4−2 lib/cliapp/src/Obelisk/CliApp/Demo.hs+4−1 lib/cliapp/src/Obelisk/CliApp/Logging.hs+42−15 lib/cliapp/src/Obelisk/CliApp/Process.hs+34−14 lib/cliapp/src/Obelisk/CliApp/Spinner.hs+4−4 lib/cliapp/src/Obelisk/CliApp/Types.hs+36−45 lib/command/src/Obelisk/App.hs+41−7 lib/command/src/Obelisk/Command.hs+16−1 lib/command/src/Obelisk/Command/Nix.hs+18−18 lib/command/src/Obelisk/Command/Run.hs+1−1 lib/command/src/Obelisk/Command/Thunk.hs+4−1

lib/cliapp/obelisk-cliapp.cabal+1

@@ -12,6 +12,7 @@ library

1212 , bytestring

1313 , exceptions

1414 , io-streams

15+ , lens

1516 , logging-effect

1617 , monad-loops

1718 , mtl

lib/cliapp/src/Obelisk/CliApp.hs+4−2

@@ -8,7 +8,6 @@ module Obelisk.CliApp

88 -- .Types

99 CliLog

1010 , CliThrow

11− , Cli

1211 , CliT(..)

1312 , runCli

1413 , CliConfig

@@ -22,17 +21,20 @@ module Obelisk.CliApp

2221 , withSpinner'

2322

2423 -- .Logging

24+ , AsUnstructuredError (..)

2525 , newCliConfig

2626 , getLogLevel

2727 , putLog

2828 , failWith

29+ , errorToWarning

2930 , withExitFailMessage

3031

3132 -- Control.Monad.Log

3233 , Severity (..)

3334

3435 -- .Process

35− , ProcessFailed (..)

36+ , ProcessFailure (..)

37+ , AsProcessFailure (..)

3638 , readProcessAndLogStderr

3739 , readProcessAndLogOutput

3840 , callProcessAndLogOutput

lib/cliapp/src/Obelisk/CliApp/Demo.hs+4−1

@@ -13,7 +13,10 @@ import Control.Monad.Catch (MonadMask)

1313

1414import Obelisk.CliApp

1515

16−cliDemo :: (MonadIO m, MonadMask m, Cli m, HasCliConfig m) => m ()

16+cliDemo

17+ :: ( MonadIO m, MonadMask m

18+ , CliLog m, HasCliConfig e m, CliThrow e m, AsProcessFailure e, AsUnstructuredError e)

19+ => m ()

1720cliDemo = withSpinner "CLI Demo" $ do

1821 putLog Notice "This demo will showcase the CLI library functionality"

1922 _ <- withSpinner' "Searching long for something" (Just $ \c -> "Discovered " <> T.pack (show c) <> " objects") $ do

lib/cliapp/src/Obelisk/CliApp/Logging.hs+42−15

@@ -4,11 +4,13 @@

44{-# LANGUAGE LambdaCase #-}

55{-# LANGUAGE MultiParamTypeClasses #-}

66{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE RankNTypes #-}

78{-# LANGUAGE ScopedTypeVariables #-}

89-- | Provides a logging handler that facilitates safe ouputting to terminal using MVar based locking.

910-- | Spinner.hs and Process.hs work on this guarantee.

1011module Obelisk.CliApp.Logging

11− ( newCliConfig

12+ ( AsUnstructuredError (..)

13+ , newCliConfig

1214 , runCli

1315 , verboseLogLevel

1416 , isOverwrite

@@ -18,6 +20,7 @@ module Obelisk.CliApp.Logging

1820 , putLog

1921 , putLogRaw

2022 , failWith

23+ , errorToWarning

2124 , withExitFailMessage

2225 , writeLog

2326 , allowUserToMakeLoggingVerbose

@@ -27,6 +30,7 @@ module Obelisk.CliApp.Logging

2730

2831import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)

2932import Control.Concurrent.MVar (modifyMVar_, newMVar)

33+import Control.Lens (Prism', review)

3034import Control.Monad (unless, void, when)

3135import Control.Monad.Catch (MonadCatch, MonadMask, bracket, catch, throwM)

3236import Control.Monad.Except (throwError)

@@ -48,17 +52,23 @@ import System.IO (BufferMode (NoBuffering), hFlush, hReady, hSetBuffering, stder

4852import qualified Obelisk.CliApp.TerminalString as TS

4953import Obelisk.CliApp.Types

5054

51−newCliConfig :: Severity -> Bool -> Bool -> IO CliConfig

52−newCliConfig sev noColor noSpinner = do

55+newCliConfig

56+ :: Severity

57+ -> Bool

58+ -> Bool

59+ -> (e -> (Text, Int))

60+ -> IO (CliConfig e)

61+newCliConfig sev noColor noSpinner errorLogExitCode = do

5362 level <- newIORef sev

5463 lock <- newMVar False

5564 tipDisplayed <- newIORef False

5665 stack <- newIORef ([], [])

57− return $ CliConfig level noColor noSpinner lock tipDisplayed stack

66+ return $ CliConfig level noColor noSpinner lock tipDisplayed stack errorLogExitCode

5867

59−runCli :: MonadIO m => CliConfig -> CliT m a -> m a

68+runCli :: MonadIO m => CliConfig e -> CliT e m a -> m a

6069runCli c =

6170 flip runLoggingT (handleLog c)

71+ . flip runReaderT (_cliConfig_errorLogExitCode c)

6272 . unDieT

6373 . flip runReaderT c

6474 . unCliT

@@ -77,18 +87,18 @@ getSeverity = \case

7787 Output_LogRaw (WithSeverity sev _) -> Just sev

7888 _ -> Nothing

7989

80−getLogLevel :: (MonadIO m, HasCliConfig m) => m Severity

90+getLogLevel :: (MonadIO m, HasCliConfig e m) => m Severity

8191getLogLevel = getLogLevel' =<< getCliConfig

8292

83−getLogLevel' :: MonadIO m => CliConfig -> m Severity

93+getLogLevel' :: MonadIO m => CliConfig e -> m Severity

8494getLogLevel' = liftIO . readIORef . _cliConfig_logLevel

8595

86−setLogLevel :: (MonadIO m, HasCliConfig m) => Severity -> m ()

96+setLogLevel :: (MonadIO m, HasCliConfig e m) => Severity -> m ()

8797setLogLevel sev = do

8898 l <- _cliConfig_logLevel <$> getCliConfig

8999 liftIO $ writeIORef l sev

90100

91−handleLog :: MonadIO m => CliConfig -> Output -> m ()

101+handleLog :: MonadIO m => CliConfig e -> Output -> m ()

92102handleLog conf output = do

93103 level <- getLogLevel' conf

94104 liftIO $ modifyMVar_ (_cliConfig_lock conf) $ \wasOverwriting -> do

@@ -126,17 +136,34 @@ handleLog' noColor output = do

126136 return $ isOverwrite output

127137

128138-- | Like `putLog` but without the implicit newline added.

129−putLogRaw :: Cli m => Severity -> Text -> m ()

139+putLogRaw :: CliLog m => Severity -> Text -> m ()

130140putLogRaw sev = logMessage . Output_LogRaw . WithSeverity sev

131141

142+-- | Indicates unstructured errors form one variant (or conceptual projection)

143+-- of the error type.

144+--

145+-- Shouldn't really use this, but who has time to clean up that much!

146+class AsUnstructuredError e where

147+ asUnstructuredError :: Prism' e Text

148+

149+instance AsUnstructuredError Text where

150+ asUnstructuredError = id

151+

132152-- | Like `putLog Alert` but also abrupts the program.

133−failWith :: CliThrow m => Text -> m a

134−failWith = throwError . Left

153+failWith :: (CliThrow e m, AsUnstructuredError e) => Text -> m a

154+failWith = throwError . review asUnstructuredError

155+

156+errorToWarning

157+ :: (HasCliConfig e m, CliThrow e m, CliLog m)

158+ => e -> m ()

159+errorToWarning e = do

160+ c <- getCliConfig

161+ putLog Warning $ fst $ _cliConfig_errorLogExitCode c e

135162

136163-- | Intercept ExitFailure exceptions and log the given alert before exiting.

137164--

138165-- This is useful when you want to provide contextual information to a deeper failure.

139−withExitFailMessage :: (Cli m, MonadCatch m) => Text -> m a -> m a

166+withExitFailMessage :: (CliLog m, MonadCatch m) => Text -> m a -> m a

140167withExitFailMessage msg f = f `catch` \(e :: ExitCode) -> do

141168 case e of

142169 ExitFailure _ -> putLog Alert msg

@@ -162,7 +189,7 @@ writeLog withNewLine noColor (WithSeverity severity s)

162189--

163190-- Call this function in a thread, and kill it to turn off keystroke monitoring.

164191allowUserToMakeLoggingVerbose

165− :: (MonadIO m, MonadMask m, Cli m, HasCliConfig m)

192+ :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)

166193 => String -- ^ The key to press in order to make logging verbose

167194 -> m ()

168195allowUserToMakeLoggingVerbose keyCode = bracket showTip (liftIO . killThread) $ \_ -> do

@@ -195,7 +222,7 @@ getChars = reverse <$> f mempty

195222 True -> f (x:xs)

196223 False -> return (x:xs)

197224

198−fork :: (HasCliConfig m, MonadIO m) => CliT IO () -> m ThreadId

225+fork :: (HasCliConfig e m, MonadIO m) => CliT e IO () -> m ThreadId

199226fork f = do

200227 c <- getCliConfig

201228 liftIO $ forkIO $ runCli c f

lib/cliapp/src/Obelisk/CliApp/Process.hs+34−14

@@ -9,7 +9,8 @@

99-- | An extension of `System.Process` that integrates with logging (`Obelisk.CLI.Logging`)

1010-- and is thus spinner friendly.

1111module Obelisk.CliApp.Process

12− ( ProcessFailed (..)

12+ ( ProcessFailure (..)

13+ , AsProcessFailure (..)

1314 , readProcessAndLogStderr

1415 , readProcessAndLogOutput

1516 , callProcessAndLogOutput

@@ -22,6 +23,7 @@ module Obelisk.CliApp.Process

2223import Control.Monad ((<=<), join, void)

2324import Control.Monad.Except (throwError)

2425import Control.Monad.IO.Class (MonadIO, liftIO)

26+import Control.Lens (Prism', review)

2527import qualified Data.ByteString as BS

2628import qualified Data.ByteString.Char8 as BSC

2729import Data.Function (fix)

@@ -41,10 +43,22 @@ import qualified System.Process as Process

4143

4244import Control.Monad.Log (Severity (..))

4345import Obelisk.CliApp.Logging (putLog, putLogRaw)

44−import Obelisk.CliApp.Types (Cli, ProcessFailed (..), reconstructCommand)

46+import Obelisk.CliApp.Types (CliLog, CliThrow)

47+

48+-- TODO put back in `Obelisk.CliApp.Process` and use prisms for extensible exceptions

49+data ProcessFailure = ProcessFailure Process.CmdSpec Int -- exit code

50+ deriving Show

51+

52+-- | Indicates arbitrary process failures form one variant (or conceptual projection) of

53+-- the error type.

54+class AsProcessFailure e where

55+ asProcessFailure :: Prism' e ProcessFailure

56+

57+instance AsProcessFailure ProcessFailure where

58+ asProcessFailure = id

4559

4660readProcessAndLogStderr

47− :: (MonadIO m, Cli m)

61+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

4862 => Severity -> CreateProcess -> m Text

4963readProcessAndLogStderr sev process = do

5064 (out, _err) <- withProcess process $ \_out err -> do

@@ -58,9 +72,8 @@ readProcessAndLogStderr sev process = do

5872-- some processes are known to spit out diagnostic or informative messages in stderr, in

5973-- which case it is advisable to call it with a non-Error severity for stderr, like

6074-- `callProcessAndLogOutput (Debug, Debug)`.

61−

6275readProcessAndLogOutput

63− :: (MonadIO m, Cli m)

76+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

6477 => (Severity, Severity) -> CreateProcess -> m Text

6578readProcessAndLogOutput (sev_out, sev_err) process = do

6679 (_, Just out, Just err, p) <- createProcess $ process

@@ -73,7 +86,7 @@ readProcessAndLogOutput (sev_out, sev_err) process = do

7386

7487 liftIO (waitForProcess p) >>= \case

7588 ExitSuccess -> pure outText

76− ExitFailure code -> throwError $ Right $ ProcessFailed (cmdspec process) code

89+ ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (cmdspec process) code

7790

7891-- | Like `System.Process.callProcess` but logs the combined output (stdout and stderr)

7992-- with the corresponding severity.

@@ -84,7 +97,7 @@ readProcessAndLogOutput (sev_out, sev_err) process = do

8497-- `callProcessAndLogOutput (Debug, Debug)`.

8598callProcessAndLogOutput

8699

87− :: (MonadIO m, Cli m)

100+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

88101 => (Severity, Severity) -> CreateProcess -> m ()

89102callProcessAndLogOutput (sev_out, sev_err) process =

90103 void $ withProcess process $ \out err -> do

@@ -97,7 +110,7 @@ callProcessAndLogOutput (sev_out, sev_err) process =

97110

98111-- | Like `System.Process.createProcess` but also logs (debug) the process being run

99112createProcess

100− :: (MonadIO m, Cli m)

113+ :: (MonadIO m, CliLog m)

101114 => CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)

102115createProcess p = do

103116 putLog Debug $ "Creating process: " <> reconstructCommand (cmdspec p)

@@ -105,7 +118,7 @@ createProcess p = do

105118

106119-- | Like `System.Process.createProcess_` but also logs (debug) the process being run

107120createProcess_

108− :: (MonadIO m, Cli m)

121+ :: (MonadIO m, CliLog m)

109122 => String -> CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)

110123createProcess_ name p = do

111124 putLog Debug $ "Creating process " <> T.pack name <> ": " <> reconstructCommand (cmdspec p)

@@ -113,7 +126,7 @@ createProcess_ name p = do

113126

114127-- | Like `System.Process.callProcess` but also logs (debug) the process being run

115128callProcess

116− :: (MonadIO m, Cli m)

129+ :: (MonadIO m, CliLog m)

117130 => String -> [String] -> m ()

118131callProcess exe args = do

119132 putLog Debug $ "Calling process " <> T.pack exe <> " with args: " <> T.pack (show args)

@@ -121,14 +134,14 @@ callProcess exe args = do

121134

122135-- | Like `System.Process.callCommand` but also logs (debug) the command being run

123136callCommand

124− :: (MonadIO m, Cli m)

137+ :: (MonadIO m, CliLog m)

125138 => String -> m ()

126139callCommand cmd = do

127140 putLog Debug $ "Calling command " <> T.pack cmd

128141 liftIO $ Process.callCommand cmd

129142

130143withProcess

131− :: (MonadIO m, Cli m)

144+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

132145 => CreateProcess -> (Handle -> Handle -> m ()) -> m (Handle, Handle)

133146withProcess process f = do -- TODO: Use bracket.

134147 -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.

@@ -139,7 +152,7 @@ withProcess process f = do -- TODO: Use bracket.

139152

140153 liftIO (waitForProcess p) >>= \case

141154 ExitSuccess -> return (out, err)

142− ExitFailure code -> throwError $ Right $ ProcessFailed (cmdspec process) code

155+ ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (cmdspec process) code

143156

144157-- Create an input stream from the file handle, associating each item with the given severity.

145158streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))

@@ -147,9 +160,16 @@ streamHandle sev = Streams.map (sev,) <=< handleToInputStream

147160

148161-- | Read from an input stream and log its contents

149162streamToLog

150− :: (MonadIO m, Cli m)

163+ :: (MonadIO m, CliLog m)

151164 => InputStream (Severity, BSC.ByteString) -> m ()

152165streamToLog stream = fix $ \loop -> do

153166 liftIO (Streams.read stream) >>= \case

154167 Nothing -> return ()

155168 Just (sev, line) -> putLogRaw sev (T.decodeUtf8 line) >> loop

169+

170+reconstructCommand :: Process.CmdSpec -> Text

171+reconstructCommand (Process.ShellCommand str) = T.pack str

172+reconstructCommand (Process.RawCommand c as) = processToShellString c as

173+ where

174+ processToShellString cmd args = T.unwords $ map quoteAndEscape (cmd : args)

175+ quoteAndEscape x = "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

lib/cliapp/src/Obelisk/CliApp/Spinner.hs+4−4

@@ -24,11 +24,11 @@ import System.Console.ANSI (Color (Blue, Cyan, Green, Red))

2424

2525import Obelisk.CliApp.Logging (allowUserToMakeLoggingVerbose, fork, putLog)

2626import Obelisk.CliApp.TerminalString (TerminalString (..), enquiryCode)

27−import Obelisk.CliApp.Types (Cli, CliConfig (..), HasCliConfig, Output (..), getCliConfig)

27+import Obelisk.CliApp.Types (CliLog, CliConfig (..), HasCliConfig, Output (..), getCliConfig)

2828

2929-- | Run an action with a CLI spinner.

3030withSpinner

31− :: (MonadIO m, MonadMask m, Cli m, HasCliConfig m)

31+ :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)

3232 => Text -> m a -> m a

3333withSpinner s = withSpinner' s $ Just $ const s

3434

@@ -39,13 +39,13 @@ withSpinner s = withSpinner' s $ Just $ const s

3939-- The 'no trail' property automatically carries over to sub-spinners (in that

4040-- they won't leave a trail either).

4141withSpinnerNoTrail

42− :: (MonadIO m, MonadMask m, Cli m, HasCliConfig m)

42+ :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)

4343 => Text -> m a -> m a

4444withSpinnerNoTrail s = withSpinner' s Nothing

4545

4646-- | Advanced version that controls the display and content of the trail message.

4747withSpinner'

48− :: (MonadIO m, MonadMask m, Cli m, HasCliConfig m)

48+ :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)

4949 => Text

5050 -> Maybe (a -> Text) -- ^ Leave an optional trail with the given message creator

5151 -> m a

lib/cliapp/src/Obelisk/CliApp/Types.hs+36−45

@@ -1,16 +1,18 @@

11{-# LANGUAGE ConstraintKinds #-}

22{-# LANGUAGE FlexibleContexts #-}

33{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FunctionalDependencies #-}

45{-# LANGUAGE LambdaCase #-}

56{-# LANGUAGE GeneralizedNewtypeDeriving #-}

67{-# LANGUAGE MultiParamTypeClasses #-}

78{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE UndecidableInstances #-}

810module Obelisk.CliApp.Types where

911

1012import Control.Concurrent.MVar (MVar)

1113import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)

1214import Control.Monad.Log (LoggingT, MonadLog, Severity (..), WithSeverity (..), logMessage)

13−import Control.Monad.Reader (MonadIO, ReaderT (..), MonadReader, ask)

15+import Control.Monad.Reader (MonadIO, ReaderT (..), MonadReader (..), ask, mapReaderT)

1416import Control.Monad.Writer (WriterT)

1517import Control.Monad.State (StateT)

1618import Control.Monad.Except (ExceptT, MonadError (..))

@@ -18,9 +20,7 @@ import Control.Monad.IO.Class (liftIO)

1820import Control.Monad.Trans (MonadTrans, lift)

1921import Data.IORef (IORef)

2022import Data.Text (Text)

21−import qualified Data.Text as T

2223import System.Exit (ExitCode (..), exitWith)

23−import qualified System.Process as Process

2424

2525import Obelisk.CliApp.TerminalString (TerminalString)

2626

@@ -36,57 +36,44 @@ data Output

3636

3737type CliLog m = MonadLog Output m

3838

39−type CliThrow m = MonadError (Either Text ProcessFailed) m

40−

41−-- TODO could remove for granularity

42−type Cli m = (CliLog m, CliThrow m)

39+type CliThrow e m = MonadError e m

4340

4441-- | Log a message to the console.

4542--

4643-- Logs safely even if there are ongoing spinners.

47−putLog :: Cli m => Severity -> Text -> m ()

44+putLog :: CliLog m => Severity -> Text -> m ()

4845putLog sev = logMessage . Output_Log . WithSeverity sev

4946

50−-- TODO put back in `Obelisk.CliApp.Process` and use prisms for extensible exceptions

51−data ProcessFailed = ProcessFailed Process.CmdSpec Int -- exit code

52− deriving Show

53−

54−-- TODO put back in `Obelisk.CliApp.Process`

55−reconstructCommand :: Process.CmdSpec -> Text

56−reconstructCommand (Process.ShellCommand str) = T.pack str

57−reconstructCommand (Process.RawCommand c as) = processToShellString c as

58− where

59− processToShellString cmd args = T.unwords $ map quoteAndEscape (cmd : args)

60− quoteAndEscape x = "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

61−

62−

63−newtype DieT m a = DieT { unDieT :: LoggingT Output m a }

47+newtype DieT e m a = DieT { unDieT :: ReaderT (e -> (Text, Int)) (LoggingT Output m) a }

6448 deriving

6549 ( Functor, Applicative, Monad, MonadIO

66− , MonadReader r

6750 , MonadThrow, MonadCatch, MonadMask

6851 , MonadLog Output

6952 )

7053

71−instance MonadTrans DieT where

72− lift = DieT . lift

54+instance MonadTrans (DieT e) where

55+ lift = DieT . lift . lift

56+

57+-- | Error printer is private to DieT

58+instance MonadReader r m => MonadReader r (DieT e m) where

59+ ask = DieT $ lift $ ask

60+ local = (\f (DieT a) -> DieT $ f a) . mapReaderT . local

61+ reader = DieT . lift . lift . reader

7362

7463-- TODO generalize to bigger error types

75−instance MonadIO m => MonadError (Either Text ProcessFailed) (DieT m) where

76− throwError = \case

77− Left s -> do

78− putLog Alert s

79− liftIO $ exitWith $ ExitFailure 2

80− Right (ProcessFailed p code) -> do

81− putLog Alert $ "Process exited with code " <> T.pack (show code) <> "; " <> T.pack (show p)

82− liftIO $ exitWith $ ExitFailure 2

64+instance MonadIO m => MonadError e (DieT e m) where

65+ throwError e = do

66+ handler <- DieT ask

67+ let (output, exitCode) = handler e

68+ putLog Alert output

69+ liftIO $ exitWith $ ExitFailure exitCode

8370

8471 -- Cannot catch

8572 catchError m _ = m

8673

8774--------------------------------------------------------------------------------

8875

89−data CliConfig = CliConfig

76+data CliConfig e = CliConfig

9077 { -- | We are capable of changing the log level at runtime

9178 _cliConfig_logLevel :: IORef Severity

9279 , -- | Disallow coloured output

@@ -99,36 +86,40 @@ data CliConfig = CliConfig

9986 _cliConfig_tipDisplayed :: IORef Bool

10087 , -- | Stack of logs from nested spinners

10188 _cliConfig_spinnerStack :: IORef ([Bool], [TerminalString])

89+ , -- | Failure handler. How to log error and what exit status to use.

90+ _cliConfig_errorLogExitCode :: e -> (Text, Int)

10291 }

10392

104−class Monad m => HasCliConfig m where

105− getCliConfig :: m CliConfig

93+class Monad m => HasCliConfig e m | m -> e where

94+ getCliConfig :: m (CliConfig e)

10695

107−instance HasCliConfig m => HasCliConfig (ReaderT r m) where

96+instance HasCliConfig e m => HasCliConfig e (ReaderT r m) where

10897 getCliConfig = lift getCliConfig

10998

110−instance (Monoid w, HasCliConfig m) => HasCliConfig (WriterT w m) where

99+instance (Monoid w, HasCliConfig e m) => HasCliConfig e (WriterT w m) where

111100 getCliConfig = lift getCliConfig

112101

113−instance HasCliConfig m => HasCliConfig (StateT s m) where

102+instance HasCliConfig e m => HasCliConfig e (StateT s m) where

114103 getCliConfig = lift getCliConfig

115104

116−instance HasCliConfig m => HasCliConfig (ExceptT e m) where

105+instance HasCliConfig e m => HasCliConfig e (ExceptT e m) where

117106 getCliConfig = lift getCliConfig

118107

119108--------------------------------------------------------------------------------

120109

121−newtype CliT m a = CliT

122− { unCliT :: ReaderT CliConfig (DieT m) a

110+newtype CliT e m a = CliT

111+ { unCliT :: ReaderT (CliConfig e) (DieT e m) a

123112 }

124113 deriving

125114 ( Functor, Applicative, Monad, MonadIO

126115 , MonadThrow, MonadCatch, MonadMask

127− , MonadLog Output, MonadError (Either Text ProcessFailed), MonadReader CliConfig

116+ , MonadLog Output -- CliLog

117+ , MonadError e -- CliThrow

118+ , MonadReader (CliConfig e) -- HasCliConfig

128119 )

129120

130−instance MonadTrans CliT where

121+instance MonadTrans (CliT e) where

131122 lift = CliT . lift . lift

132123

133−instance Monad m => HasCliConfig (CliT m) where

124+instance Monad m => HasCliConfig e (CliT e m)where

134125 getCliConfig = ask

lib/command/src/Obelisk/App.hs+41−7

@@ -2,11 +2,15 @@

22{-# LANGUAGE FlexibleContexts #-}

33{-# LANGUAGE FlexibleInstances #-}

44{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE LambdaCase #-}

56{-# LANGUAGE MultiParamTypeClasses #-}

67{-# LANGUAGE ScopedTypeVariables #-}

78{-# LANGUAGE StandaloneDeriving #-}

9+{-# LANGUAGE TemplateHaskell #-}

10+{-# LANGUAGE TupleSections #-}

811module Obelisk.App where

912

13+import Control.Lens

1014import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)

1115import Control.Monad.Reader (MonadIO, ReaderT (..), ask, runReaderT)

1216import Control.Monad.Writer (WriterT)

@@ -17,20 +21,50 @@ import Data.Text (Text)

1721import System.Directory (XdgDirectory (XdgData), getXdgDirectory)

1822import Control.Monad.Log (MonadLog)

1923

20−import Obelisk.CliApp (CliConfig, CliLog, CliThrow, CliT (..), HasCliConfig, runCli, Output, ProcessFailed)

24+import Obelisk.CliApp

25+ ( CliConfig

26+ , CliLog

27+ , CliThrow

28+ , CliT (..)

29+ , ProcessFailure

30+ , AsProcessFailure (..)

31+ , AsUnstructuredError (..)

32+ , HasCliConfig

33+ , Output

34+ , runCli

35+ )

36+

37+data ObeliskError

38+ = ObeliskError_ProcessError

39+ { obeliskError_err :: ProcessFailure

40+ , obeliskError_mAnn :: Maybe Text

41+ }

42+ | ObeliskError_Unstructured Text

43+

44+makePrisms ''ObeliskError

45+

46+instance AsUnstructuredError ObeliskError where

47+ asUnstructuredError = _ObeliskError_Unstructured

48+

49+-- Only project when the other field is null, otherwise we are not law abiding.

50+instance AsProcessFailure ObeliskError where

51+ asProcessFailure = _ObeliskError_ProcessError . prism (, Nothing) f

52+ where f = \case

53+ (pf, Nothing) -> Right pf

54+ pann@(_, Just _) -> Left pann

2155

2256newtype Obelisk = Obelisk

23− { _obelisk_cliConfig :: CliConfig

57+ { _obelisk_cliConfig :: CliConfig ObeliskError

2458 }

2559

2660newtype ObeliskT m a = ObeliskT

27− { unObeliskT :: ReaderT Obelisk (CliT m) a

61+ { unObeliskT :: ReaderT Obelisk (CliT ObeliskError m) a

2862 }

2963 deriving

3064 ( Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask

3165 , MonadLog Output -- CliLog

32− , MonadError (Either Text ProcessFailed) -- CliThrow

33− , HasCliConfig)

66+ , MonadError ObeliskError -- CliThrow ObeliskError

67+ , HasCliConfig ObeliskError)

3468

3569instance MonadTrans ObeliskT where

3670 lift = ObeliskT . lift . lift

@@ -61,7 +95,7 @@ runObelisk c =

6195

6296type MonadInfallibleObelisk m =

6397 ( CliLog m

64− , HasCliConfig m

98+ , HasCliConfig ObeliskError m

6599 , HasObelisk m

66100 , MonadIO m

67101 , MonadMask m

@@ -69,7 +103,7 @@ type MonadInfallibleObelisk m =

69103

70104type MonadObelisk m =

71105 ( MonadInfallibleObelisk m

72− , CliThrow m

106+ , CliThrow ObeliskError m

73107 )

74108

75109getObeliskUserStateDir :: IO FilePath

lib/command/src/Obelisk/Command.hs+16−1

@@ -269,7 +269,22 @@ mkObeliskConfig = do

269269 -- This function should not use argument parser (full argument parsing happens post handoff)

270270 let logLevel = toLogLevel $ "-v" `elem` cliArgs

271271 notInteractive <- not <$> isInteractiveTerm

272− cliConf <- newCliConfig logLevel notInteractive notInteractive

272+-- instance MonadIO m => MonadError (Either Text ProcessFailed) (DieT m) where

273+-- throwError = \case

274+-- Left s -> do

275+-- putLog Alert s

276+-- liftIO $ exitWith $ ExitFailure 2

277+-- Right (ProcessFailed p code) -> do

278+-- putLog Alert $ "Process exited with code " <> T.pack (show code) <> "; " <> T.pack (show p)

279+-- liftIO $ exitWith $ ExitFailure 2

280+ cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case

281+ ObeliskError_ProcessError (ProcessFailure p code) ann ->

282+ ( "Process exited with code " <> T.pack (show code) <> "; " <> T.pack (show p)

283+ <> maybe "" ("\n\n" <>) ann

284+ , 2

285+ )

286+ ObeliskError_Unstructured msg -> (msg, 2)

287+

273288 return $ Obelisk cliConf

274289 where

275290 toLogLevel = bool Notice Debug

lib/command/src/Obelisk/Command/Nix.hs+18−18

@@ -20,19 +20,19 @@ module Obelisk.Command.Nix

2020 ) where

2121

2222--import Control.Monad.Catch (catch, throwM)

23+import Control.Lens

2324import Control.Monad.Except (ExceptT, runExceptT, throwError)

2425import Control.Monad.IO.Class (liftIO)

2526import Data.Bool (bool)

2627import Data.Default

2728import Data.List (intercalate)

2829import Data.Monoid ((<>))

29−import Data.Text (Text)

3030import qualified Data.Text as T

3131import System.Directory

3232import System.Environment

3333import System.Process (proc)

3434

35−import Obelisk.App (MonadInfallibleObelisk, MonadObelisk)

35+import Obelisk.App (MonadInfallibleObelisk, MonadObelisk, ObeliskError (..))

3636import Obelisk.CliApp

3737

3838-- | Where to put nix-build output

@@ -111,25 +111,25 @@ nixBuild cfg = withSpinner' ("Running nix-build on " <> desc) (Just $ const $ "B

111111-- Added: June, 2018. Consider removing this eventually.

112112withNixRemoteCheck

113113 :: MonadObelisk m

114− => (forall m'. MonadInfallibleObelisk m' => ExceptT (Either Text ProcessFailed) m' a)

114+ => (forall m'. MonadInfallibleObelisk m' => ExceptT ObeliskError m' a)

115115 -> m a

116116withNixRemoteCheck f = do

117117 status <- runExceptT f

118118 case status of

119119 Right a -> pure a

120− Left (Left t) -> throwError $ Left t

121− Left (Right e) -> do

122− liftIO (lookupEnv "NIX_REMOTE") >>= \case

123− Just _ -> throwError $ Right e

120+ Left e -> throwError =<< case matching asProcessFailure e of

121+ Left _ -> pure e

122+ Right pf -> liftIO (lookupEnv "NIX_REMOTE") >>= \case

123+ Just _ -> pure e

124124 Nothing -> liftIO (writable <$> getPermissions "/nix/var/nix/db") >>= \case

125− True -> throwError $ Right e

126− False -> do

127− putLog Error "!!! "

128− putLog Error "!!! A nix command failed to run. You might need to set the NIX_REMOTE environment variable"

129− putLog Error "!!! to `daemon`. To do this, run the following before running obelisk:"

130− putLog Error "!!! "

131− putLog Error "!!! export NIX_REMOTE=daemon"

132− putLog Error "!!! "

133− putLog Error "!!! For details, see https://github.com/NixOS/nixpkgs/issues/5713"

134− putLog Error "!!! "

135− throwError $ Right e

125+ True -> pure e

126+ False -> pure $ ObeliskError_ProcessError pf $ Just $ T.unlines

127+ [ "!!! "

128+ , "!!! A nix command failed to run. You might need to set the NIX_REMOTE environment variable"

129+ , "!!! to `daemon`. To do this, run the following before running obelisk:"

130+ , "!!! "

131+ , "!!! export NIX_REMOTE=daemon"

132+ , "!!! "

133+ , "!!! For details, see https://github.com/NixOS/nixpkgs/issues/5713"

134+ , "!!! "

135+ ]

lib/command/src/Obelisk/Command/Run.hs+1−1

@@ -112,7 +112,7 @@ parseCabalPackage dir = do

112112 mapM_ (putLog Error) $ fmap (T.pack . show) errors

113113 return Nothing

114114

115−withUTF8FileContentsM :: (MonadIO m, HasCliConfig m) => FilePath -> (ByteString -> CliT IO a) -> m a

115+withUTF8FileContentsM :: (MonadIO m, HasCliConfig e m) => FilePath -> (ByteString -> CliT e IO a) -> m a

116116withUTF8FileContentsM fp f = do

117117 c <- getCliConfig

118118 liftIO $ withUTF8FileContents fp $ runCli c . f . toUTF8BS

lib/command/src/Obelisk/Command/Thunk.hs+4−1

@@ -131,7 +131,10 @@ commitNameToRef :: Name Commit -> Ref

131131commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c

132132

133133-- TODO: Use spinner here.

134−getNixSha256ForUriUnpacked :: MonadObelisk m => URI -> m NixSha256

134+getNixSha256ForUriUnpacked

135+ :: MonadObelisk m

136+ => URI

137+ -> m NixSha256

135138getNixSha256ForUriUnpacked uri =

136139 withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> T.pack (show uri)) $ do

137140 withNixRemoteCheck $ readProcessAndLogStderr Debug $