2760991 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

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

2760991John Ericson8 years ago

lib/cliapp/obelisk-cliapp.cabal+1

compare with master

unifiedsplit

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

12 , bytestring

13 , exceptions

14 , io-streams

15+ , lens

15 , logging-effect

16 , logging-effect

16 , monad-loops

17 , monad-loops

17 , mtl

18 , mtl

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

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

8 -- .Types

9 CliLog

10 , CliThrow

11− , Cli

12 , CliT(..)

11 , CliT(..)

13 , runCli

12 , runCli

14 , CliConfig

13 , CliConfig

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

22 , withSpinner'

21 , withSpinner'

24 -- .Logging

23 -- .Logging

24+ , AsUnstructuredError (..)

25 , newCliConfig

26 , getLogLevel

27 , putLog

28 , failWith

29+ , errorToWarning

29 , withExitFailMessage

30 , withExitFailMessage

31 -- Control.Monad.Log

32 -- Control.Monad.Log

32 , Severity (..)

33 , Severity (..)

34 -- .Process

35 -- .Process

35− , ProcessFailed (..)

36+ , ProcessFailure (..)

37+ , AsProcessFailure (..)

36 , readProcessAndLogStderr

38 , readProcessAndLogStderr

37 , readProcessAndLogOutput

39 , readProcessAndLogOutput

38 , callProcessAndLogOutput

40 , callProcessAndLogOutput

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

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

14import Obelisk.CliApp

16+cliDemo

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

17+ :: ( MonadIO m, MonadMask m

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

19+ => m ()

17cliDemo = withSpinner "CLI Demo" $ do

20cliDemo = withSpinner "CLI Demo" $ do

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

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

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

22 _ <- 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 @@

4{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

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

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

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

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

10module Obelisk.CliApp.Logging

11module Obelisk.CliApp.Logging

12+ ( AsUnstructuredError (..)

11− ( newCliConfig

13+ , newCliConfig

12 , runCli

14 , runCli

13 , verboseLogLevel

15 , verboseLogLevel

14 , isOverwrite

16 , isOverwrite

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

18 , putLog

20 , putLog

19 , putLogRaw

21 , putLogRaw

20 , failWith

22 , failWith

23+ , errorToWarning

21 , withExitFailMessage

24 , withExitFailMessage

22 , writeLog

25 , writeLog

23 , allowUserToMakeLoggingVerbose

26 , allowUserToMakeLoggingVerbose

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

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

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

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

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

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

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

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

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

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

32import Control.Monad.Except (throwError)

36import Control.Monad.Except (throwError)

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

48import qualified Obelisk.CliApp.TerminalString as TS

52import qualified Obelisk.CliApp.TerminalString as TS

49import Obelisk.CliApp.Types

53import Obelisk.CliApp.Types

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

55+newCliConfig

56+ :: Severity

57+ -> Bool

58+ -> Bool

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

60+ -> IO (CliConfig e)

52−newCliConfig sev noColor noSpinner = do

61+newCliConfig sev noColor noSpinner errorLogExitCode = do

53 level <- newIORef sev

62 level <- newIORef sev

54 lock <- newMVar False

63 lock <- newMVar False

55 tipDisplayed <- newIORef False

64 tipDisplayed <- newIORef False

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

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

57− return $ CliConfig level noColor noSpinner lock tipDisplayed stack

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

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

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

60runCli c =

69runCli c =

61 flip runLoggingT (handleLog c)

70 flip runLoggingT (handleLog c)

71+ . flip runReaderT (_cliConfig_errorLogExitCode c)

62 . unDieT

72 . unDieT

63 . flip runReaderT c

73 . flip runReaderT c

64 . unCliT

74 . unCliT

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

77 Output_LogRaw (WithSeverity sev _) -> Just sev

87 Output_LogRaw (WithSeverity sev _) -> Just sev

78 _ -> Nothing

88 _ -> Nothing

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

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

81getLogLevel = getLogLevel' =<< getCliConfig

91getLogLevel = getLogLevel' =<< getCliConfig

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

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

84getLogLevel' = liftIO . readIORef . _cliConfig_logLevel

94getLogLevel' = liftIO . readIORef . _cliConfig_logLevel

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

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

87setLogLevel sev = do

97setLogLevel sev = do

88 l <- _cliConfig_logLevel <$> getCliConfig

98 l <- _cliConfig_logLevel <$> getCliConfig

89 liftIO $ writeIORef l sev

99 liftIO $ writeIORef l sev

100

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

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

92handleLog conf output = do

102handleLog conf output = do

93 level <- getLogLevel' conf

103 level <- getLogLevel' conf

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

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

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

126 return $ isOverwrite output

136 return $ isOverwrite output

127

137

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

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

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

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

130putLogRaw sev = logMessage . Output_LogRaw . WithSeverity sev

140putLogRaw sev = logMessage . Output_LogRaw . WithSeverity sev

131

141

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+

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

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

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

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

134−failWith = throwError . Left

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

135

162

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

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

137--

164--

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

165-- 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

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

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

141 case e of

168 case e of

142 ExitFailure _ -> putLog Alert msg

169 ExitFailure _ -> putLog Alert msg

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

162--

189--

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

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

164allowUserToMakeLoggingVerbose

191allowUserToMakeLoggingVerbose

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

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

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

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

167 -> m ()

194 -> m ()

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

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

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

195 True -> f (x:xs)

222 True -> f (x:xs)

196 False -> return (x:xs)

223 False -> return (x:xs)

197

224

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

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

199fork f = do

226fork f = do

200 c <- getCliConfig

227 c <- getCliConfig

201 liftIO $ forkIO $ runCli c f

228 liftIO $ forkIO $ runCli c f

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

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

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

10-- and is thus spinner friendly.

11module Obelisk.CliApp.Process

12− ( ProcessFailed (..)

12+ ( ProcessFailure (..)

13+ , AsProcessFailure (..)

13 , readProcessAndLogStderr

14 , readProcessAndLogStderr

14 , readProcessAndLogOutput

15 , readProcessAndLogOutput

15 , callProcessAndLogOutput

16 , callProcessAndLogOutput

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

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

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

23import Control.Monad.Except (throwError)

24import Control.Monad.Except (throwError)

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

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

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

25import qualified Data.ByteString as BS

27import qualified Data.ByteString as BS

26import qualified Data.ByteString.Char8 as BSC

28import qualified Data.ByteString.Char8 as BSC

27import Data.Function (fix)

29import Data.Function (fix)

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

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

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

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

45import 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

46readProcessAndLogStderr

60readProcessAndLogStderr

47− :: (MonadIO m, Cli m)

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

48 => Severity -> CreateProcess -> m Text

62 => Severity -> CreateProcess -> m Text

49readProcessAndLogStderr sev process = do

63readProcessAndLogStderr sev process = do

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

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

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

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

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

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

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

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

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

61−

62readProcessAndLogOutput

75readProcessAndLogOutput

63− :: (MonadIO m, Cli m)

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

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

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

65readProcessAndLogOutput (sev_out, sev_err) process = do

78readProcessAndLogOutput (sev_out, sev_err) process = do

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

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

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

74 liftIO (waitForProcess p) >>= \case

87 liftIO (waitForProcess p) >>= \case

75 ExitSuccess -> pure outText

88 ExitSuccess -> pure outText

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

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

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

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

79-- with the corresponding severity.

92-- with the corresponding severity.

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

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

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

85callProcessAndLogOutput

98callProcessAndLogOutput

87− :: (MonadIO m, Cli m)

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

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

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

89callProcessAndLogOutput (sev_out, sev_err) process =

102callProcessAndLogOutput (sev_out, sev_err) process =

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

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

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

110

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

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

99createProcess

112createProcess

100− :: (MonadIO m, Cli m)

113+ :: (MonadIO m, CliLog m)

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

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

102createProcess p = do

115createProcess p = do

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

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

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

105

118

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

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

107createProcess_

120createProcess_

108− :: (MonadIO m, Cli m)

121+ :: (MonadIO m, CliLog m)

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

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

110createProcess_ name p = do

123createProcess_ name p = do

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

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

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

113

126

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

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

115callProcess

128callProcess

116− :: (MonadIO m, Cli m)

129+ :: (MonadIO m, CliLog m)

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

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

118callProcess exe args = do

131callProcess exe args = do

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

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

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

121

134

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

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

123callCommand

136callCommand

124− :: (MonadIO m, Cli m)

137+ :: (MonadIO m, CliLog m)

125 => String -> m ()

138 => String -> m ()

126callCommand cmd = do

139callCommand cmd = do

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

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

128 liftIO $ Process.callCommand cmd

141 liftIO $ Process.callCommand cmd

129

142

130withProcess

143withProcess

131− :: (MonadIO m, Cli m)

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

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

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

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

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

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

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

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

139

152

140 liftIO (waitForProcess p) >>= \case

153 liftIO (waitForProcess p) >>= \case

141 ExitSuccess -> return (out, err)

154 ExitSuccess -> return (out, err)

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

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

143

156

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

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

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

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

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

147

160

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

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

149streamToLog

162streamToLog

150− :: (MonadIO m, Cli m)

163+ :: (MonadIO m, CliLog m)

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

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

152streamToLog stream = fix $ \loop -> do

165streamToLog stream = fix $ \loop -> do

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

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

154 Nothing -> return ()

167 Nothing -> return ()

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

168 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))

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

26import 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)

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

30withSpinner

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

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

32 => Text -> m a -> m a

33withSpinner s = withSpinner' s $ Just $ const s

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

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

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

41withSpinnerNoTrail

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

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

43 => Text -> m a -> m a

44withSpinnerNoTrail s = withSpinner' s Nothing

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

47withSpinner'

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

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

49 => Text

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

51 -> m a

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

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

1{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FunctionalDependencies #-}

4{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE OverloadedStrings #-}

8{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE UndecidableInstances #-}

8module Obelisk.CliApp.Types where

10module Obelisk.CliApp.Types where

10import Control.Concurrent.MVar (MVar)

12import Control.Concurrent.MVar (MVar)

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

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

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

14import 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)

14import Control.Monad.Writer (WriterT)

16import Control.Monad.Writer (WriterT)

15import Control.Monad.State (StateT)

17import Control.Monad.State (StateT)

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

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

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

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

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

19import Data.IORef (IORef)

21import Data.IORef (IORef)

20import Data.Text (Text)

22import Data.Text (Text)

21−import qualified Data.Text as T

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

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

23−import qualified System.Process as Process

25import Obelisk.CliApp.TerminalString (TerminalString)

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

37type CliLog m = MonadLog Output m

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

39+type CliThrow e m = MonadError e m

40−

41−-- TODO could remove for granularity

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

44-- | Log a message to the console.

41-- | Log a message to the console.

45--

42--

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

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

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

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

48putLog sev = logMessage . Output_Log . WithSeverity sev

45putLog sev = logMessage . Output_Log . WithSeverity sev

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 }

64 deriving

48 deriving

65 ( Functor, Applicative, Monad, MonadIO

49 ( Functor, Applicative, Monad, MonadIO

66− , MonadReader r

67 , MonadThrow, MonadCatch, MonadMask

50 , MonadThrow, MonadCatch, MonadMask

68 , MonadLog Output

51 , MonadLog Output

69 )

52 )

71−instance MonadTrans DieT where

54+instance MonadTrans (DieT e) where

72− lift = DieT . lift

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

74-- TODO generalize to bigger error types

63-- TODO generalize to bigger error types

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

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

76− throwError = \case

65+ throwError e = do

77− Left s -> do

66+ handler <- DieT ask

78− putLog Alert s

67+ let (output, exitCode) = handler e

79− liftIO $ exitWith $ ExitFailure 2

68+ putLog Alert output

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

69+ liftIO $ exitWith $ ExitFailure exitCode

84 -- Cannot catch

71 -- Cannot catch

85 catchError m _ = m

72 catchError m _ = m

87--------------------------------------------------------------------------------

74--------------------------------------------------------------------------------

89−data CliConfig = CliConfig

76+data CliConfig e = CliConfig

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

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

91 _cliConfig_logLevel :: IORef Severity

78 _cliConfig_logLevel :: IORef Severity

92 , -- | Disallow coloured output

79 , -- | Disallow coloured output

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

99 _cliConfig_tipDisplayed :: IORef Bool

86 _cliConfig_tipDisplayed :: IORef Bool

100 , -- | Stack of logs from nested spinners

87 , -- | Stack of logs from nested spinners

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

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

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

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

102 }

91 }

103

104−class Monad m => HasCliConfig m where

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

105− getCliConfig :: m CliConfig

94+ getCliConfig :: m (CliConfig e)

106

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

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

108 getCliConfig = lift getCliConfig

97 getCliConfig = lift getCliConfig

109

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

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

111 getCliConfig = lift getCliConfig

100 getCliConfig = lift getCliConfig

112

101

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

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

114 getCliConfig = lift getCliConfig

103 getCliConfig = lift getCliConfig

115

104

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

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

117 getCliConfig = lift getCliConfig

106 getCliConfig = lift getCliConfig

118

107

119--------------------------------------------------------------------------------

108--------------------------------------------------------------------------------

120

109

121−newtype CliT m a = CliT

110+newtype CliT e m a = CliT

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

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

123 }

112 }

124 deriving

113 deriving

125 ( Functor, Applicative, Monad, MonadIO

114 ( Functor, Applicative, Monad, MonadIO

126 , MonadThrow, MonadCatch, MonadMask

115 , MonadThrow, MonadCatch, MonadMask

116+ , MonadLog Output -- CliLog

117+ , MonadError e -- CliThrow

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

118+ , MonadReader (CliConfig e) -- HasCliConfig

128 )

119 )

129

120

130−instance MonadTrans CliT where

121+instance MonadTrans (CliT e) where

131 lift = CliT . lift . lift

122 lift = CliT . lift . lift

132

123

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

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

134 getCliConfig = ask

125 getCliConfig = ask

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

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

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE StandaloneDeriving #-}

8{-# LANGUAGE StandaloneDeriving #-}

9+{-# LANGUAGE TemplateHaskell #-}

10+{-# LANGUAGE TupleSections #-}

8module Obelisk.App where

11module Obelisk.App where

13+import Control.Lens

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

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

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

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

12import Control.Monad.Writer (WriterT)

16import Control.Monad.Writer (WriterT)

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

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

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

18import Control.Monad.Log (MonadLog)

22import Control.Monad.Log (MonadLog)

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

22newtype Obelisk = Obelisk

56newtype Obelisk = Obelisk

23− { _obelisk_cliConfig :: CliConfig

57+ { _obelisk_cliConfig :: CliConfig ObeliskError

24 }

58 }

26newtype ObeliskT m a = ObeliskT

60newtype ObeliskT m a = ObeliskT

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

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

28 }

62 }

29 deriving

63 deriving

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

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

31 , MonadLog Output -- CliLog

65 , MonadLog Output -- CliLog

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

66+ , MonadError ObeliskError -- CliThrow ObeliskError

33− , HasCliConfig)

67+ , HasCliConfig ObeliskError)

35instance MonadTrans ObeliskT where

69instance MonadTrans ObeliskT where

36 lift = ObeliskT . lift . lift

70 lift = ObeliskT . lift . lift

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

62type MonadInfallibleObelisk m =

96type MonadInfallibleObelisk m =

63 ( CliLog m

97 ( CliLog m

64− , HasCliConfig m

98+ , HasCliConfig ObeliskError m

65 , HasObelisk m

99 , HasObelisk m

66 , MonadIO m

100 , MonadIO m

67 , MonadMask m

101 , MonadMask m

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

103

70type MonadObelisk m =

104type MonadObelisk m =

71 ( MonadInfallibleObelisk m

105 ( MonadInfallibleObelisk m

72− , CliThrow m

106+ , CliThrow ObeliskError m

73 )

107 )

108

75getObeliskUserStateDir :: IO FilePath

109getObeliskUserStateDir :: IO FilePath

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

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

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

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

271 notInteractive <- not <$> isInteractiveTerm

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

272− cliConf <- newCliConfig logLevel notInteractive notInteractive

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+

273 return $ Obelisk cliConf

288 return $ Obelisk cliConf

274 where

289 where

275 toLogLevel = bool Notice Debug

290 toLogLevel = bool Notice Debug

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

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

20 ) where

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

23+import Control.Lens

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

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

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

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

25import Data.Bool (bool)

26import Data.Bool (bool)

26import Data.Default

27import Data.Default

27import Data.List (intercalate)

28import Data.List (intercalate)

28import Data.Monoid ((<>))

29import Data.Monoid ((<>))

29−import Data.Text (Text)

30import qualified Data.Text as T

31import System.Directory

32import System.Environment

33import System.Process (proc)

35−import Obelisk.App (MonadInfallibleObelisk, MonadObelisk)

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

36import Obelisk.CliApp

38-- | Where to put nix-build output

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

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

112withNixRemoteCheck

113 :: MonadObelisk m

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

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

115 -> m a

116withNixRemoteCheck f = do

117 status <- runExceptT f

118 case status of

119 Right a -> pure a

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

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

121− Left (Right e) -> do

121+ Left _ -> pure e

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

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

123− Just _ -> throwError $ Right e

123+ Just _ -> pure e

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

125− True -> throwError $ Right e

125+ True -> pure e

126− False -> do

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

127− putLog Error "!!! "

127+ [ "!!! "

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

128+ , "!!! 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:"

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

130− putLog Error "!!! "

130+ , "!!! "

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

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

132− putLog Error "!!! "

132+ , "!!! "

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

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

134− putLog Error "!!! "

134+ , "!!! "

135− throwError $ Right e

135+ ]

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

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

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

113 return Nothing

114

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

116withUTF8FileContentsM fp f = do

117 c <- getCliConfig

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

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

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

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

132

133-- TODO: Use spinner here.

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

134+getNixSha256ForUriUnpacked

135+ :: MonadObelisk m

136+ => URI

137+ -> m NixSha256

135getNixSha256ForUriUnpacked uri =

138getNixSha256ForUriUnpacked uri =

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

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

137 withNixRemoteCheck $ readProcessAndLogStderr Debug $

140 withNixRemoteCheck $ readProcessAndLogStderr Debug $