3fe5a1e · obelisk · git.iko.soy

git.iko.soy/obelisk

Purge more unchecked exceptions, fixing rollback

commit3fe5a1e1f40aa662804b2b2f45120e26d8f1ae40 authorJohn Ericson <John.Ericson@Obsidian.Systems> dateWed 17 Oct 2018, 15:07 (8 years ago) parent0be51b3

6 files changed+82−59

compare with master

unifiedsplit

lib/cliapp/src/Obelisk/CliApp/Logging.hs+3−3 lib/cliapp/src/Obelisk/CliApp/Process.hs+10−25 lib/cliapp/src/Obelisk/CliApp/Types.hs+27−6 lib/command/src/Obelisk/App.hs+10−4 lib/command/src/Obelisk/Command.hs−3 lib/command/src/Obelisk/Command/Nix.hs+32−18

lib/cliapp/src/Obelisk/CliApp/Logging.hs+3−3

@@ -29,7 +29,7 @@ import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)

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

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

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

32−import Control.Monad.Except (MonadError, throwError)

32+import Control.Monad.Except (throwError)

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

3434import Control.Monad.Log (Severity (..), WithSeverity (..), logMessage, runLoggingT)

3535import Control.Monad.Loops (iterateUntil)

@@ -130,8 +130,8 @@ putLogRaw :: Cli m => Severity -> Text -> m ()

130130putLogRaw sev = logMessage . Output_LogRaw . WithSeverity sev

131131

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

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

134−failWith = throwError

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

134+failWith = throwError . Left

135135

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

137137--

lib/cliapp/src/Obelisk/CliApp/Process.hs+10−25

@@ -20,7 +20,6 @@ module Obelisk.CliApp.Process

2020 ) where

2121

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

23−import Control.Monad.Catch (Exception(..), MonadMask, throwM)

2423import Control.Monad.Except (throwError)

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

2625import qualified Data.ByteString as BS

@@ -42,17 +41,10 @@ import qualified System.Process as Process

4241

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

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

45−import Obelisk.CliApp.Types (Cli)

46−

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

48− deriving Show

49−

50−instance Exception ProcessFailed where

51− displayException (ProcessFailed spec exitCode) =

52− unwords ["ProcessFailed", reconstructCommand spec, show exitCode]

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

5345

5446readProcessAndLogStderr

55− :: (MonadIO m, MonadMask m, Cli m)

47+ :: (MonadIO m, Cli m)

5648 => Severity -> CreateProcess -> m Text

5749readProcessAndLogStderr sev process = do

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

@@ -68,7 +60,7 @@ readProcessAndLogStderr sev process = do

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

6961

7062readProcessAndLogOutput

71− :: (MonadIO m, MonadMask m, Cli m)

63+ :: (MonadIO m, Cli m)

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

7365readProcessAndLogOutput (sev_out, sev_err) process = do

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

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

8173

8274 liftIO (waitForProcess p) >>= \case

8375 ExitSuccess -> pure outText

84− ExitFailure code -> throwError $ T.pack $ show $ ProcessFailed (cmdspec process) code

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

8577

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

8779-- with the corresponding severity.

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

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

9385callProcessAndLogOutput

9486

95− :: (MonadIO m, MonadMask m, Cli m)

87+ :: (MonadIO m, Cli m)

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

9789callProcessAndLogOutput (sev_out, sev_err) process =

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

@@ -108,7 +100,7 @@ createProcess

108100 :: (MonadIO m, Cli m)

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

110102createProcess p = do

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

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

112104 liftIO $ Process.createProcess p

113105

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

@@ -116,7 +108,7 @@ createProcess_

116108 :: (MonadIO m, Cli m)

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

118110createProcess_ name p = do

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

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

120112 liftIO $ Process.createProcess p

121113

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

@@ -136,7 +128,7 @@ callCommand cmd = do

136128 liftIO $ Process.callCommand cmd

137129

138130withProcess

139− :: (MonadIO m, MonadMask m, Cli m)

131+ :: (MonadIO m, Cli m)

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

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

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

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

147139

148140 liftIO (waitForProcess p) >>= \case

149141 ExitSuccess -> return (out, err)

150− ExitFailure code -> throwM $ ProcessFailed (cmdspec process) code

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

151143

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

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

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

155147

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

157149streamToLog

158− :: (MonadIO m, MonadMask m, Cli m)

150+ :: (MonadIO m, Cli m)

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

160152streamToLog stream = fix $ \loop -> do

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

162154 Nothing -> return ()

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

164−

165−reconstructCommand :: Process.CmdSpec -> String

166−reconstructCommand (Process.ShellCommand str) = str

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

168− where

169− processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)

170− quoteAndEscape x = T.unpack $ "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

lib/cliapp/src/Obelisk/CliApp/Types.hs+27−6

@@ -1,8 +1,10 @@

11{-# LANGUAGE ConstraintKinds #-}

22{-# LANGUAGE FlexibleContexts #-}

33{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE LambdaCase #-}

45{-# LANGUAGE GeneralizedNewtypeDeriving #-}

56{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE OverloadedStrings #-}

68module Obelisk.CliApp.Types where

810import Control.Concurrent.MVar (MVar)

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

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

1719import Data.IORef (IORef)

1820import Data.Text (Text)

21+import qualified Data.Text as T

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

23+import qualified System.Process as Process

2024

2125import Obelisk.CliApp.TerminalString (TerminalString)

2226

@@ -32,7 +36,7 @@ data Output

3236

3337type CliLog m = MonadLog Output m

3438

35−type CliThrow m = MonadError Text m

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

3640

3741-- TODO could remove for granularity

3842type Cli m = (CliLog m, CliThrow m)

@@ -43,6 +47,19 @@ type Cli m = (CliLog m, CliThrow m)

4347putLog :: Cli m => Severity -> Text -> m ()

4448putLog sev = logMessage . Output_Log . WithSeverity sev

4549

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+

4663newtype DieT m a = DieT { unDieT :: LoggingT Output m a }

4764 deriving

4865 ( Functor, Applicative, Monad, MonadIO

@@ -55,10 +72,14 @@ instance MonadTrans DieT where

5572 lift = DieT . lift

5673

5774-- TODO generalize to bigger error types

58−instance MonadIO m => MonadError Text (DieT m) where

59− throwError s = do

60− putLog Alert s

61− liftIO $ exitWith $ ExitFailure 2

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

6283

6384 -- Cannot catch

6485 catchError m _ = m

@@ -103,7 +124,7 @@ newtype CliT m a = CliT

103124 deriving

104125 ( Functor, Applicative, Monad, MonadIO

105126 , MonadThrow, MonadCatch, MonadMask

106− , MonadLog Output, MonadError Text, MonadReader CliConfig

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

107128 )

108129

109130instance MonadTrans CliT where

lib/command/src/Obelisk/App.hs+10−4

@@ -17,7 +17,7 @@ import Data.Text (Text)

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

1818import Control.Monad.Log (MonadLog)

1919

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

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

2121

2222newtype Obelisk = Obelisk

2323 { _obelisk_cliConfig :: CliConfig

@@ -28,7 +28,9 @@ newtype ObeliskT m a = ObeliskT

2828 }

2929 deriving

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

31− , MonadLog Output, MonadError Text, HasCliConfig)

31+ , MonadLog Output -- CliLog

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

33+ , HasCliConfig)

3234

3335instance MonadTrans ObeliskT where

3436 lift = ObeliskT . lift . lift

@@ -57,14 +59,18 @@ runObelisk c =

5759 . flip runReaderT c

5860 . unObeliskT

5961

60−type MonadObelisk m =

62+type MonadInfallibleObelisk m =

6163 ( CliLog m

62− , CliThrow m

6364 , HasCliConfig m

6465 , HasObelisk m

6566 , MonadIO m

6667 , MonadMask m

6768 )

6869

70+type MonadObelisk m =

71+ ( MonadInfallibleObelisk m

72+ , CliThrow m

73+ )

74+

6975getObeliskUserStateDir :: IO FilePath

7076getObeliskUserStateDir = getXdgDirectory XdgData "obelisk"

lib/command/src/Obelisk/Command.hs−3

@@ -8,7 +8,6 @@

88module Obelisk.Command where

1010import Control.Monad

11−import Control.Monad.Catch (catch)

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

1312import qualified Data.Binary as Binary

1413import Data.Bool (bool)

@@ -309,8 +308,6 @@ main' argsCfg = do

309308 ]

310309

311310 (mainWithHandOff argsCfg <=< parseHandoff) =<< liftIO getArgs

312− `catch`

313− \(ProcessFailed p code) -> failWith $ "Process exited with code " <> tshow code <> "; " <> tshow p

314311

315312-- Type representing the result of a handoff calculation.

316313data HandOff m

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

@@ -1,8 +1,12 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

13{-# LANGUAGE FlexibleContexts #-}

24{-# LANGUAGE LambdaCase #-}

35{-# LANGUAGE MultiParamTypeClasses #-}

46{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE Rank2Types #-}

58{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TypeApplications #-}

610module Obelisk.Command.Nix

711 ( nixBuild

812 , withNixRemoteCheck

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

1519 , strArg

1620 ) where

1721

18−import Control.Monad.Catch (catch, throwM)

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

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

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

2025import Data.Bool (bool)

2126import Data.Default

2227import Data.List (intercalate)

2328import Data.Monoid ((<>))

29+import Data.Text (Text)

2430import qualified Data.Text as T

2531import System.Directory

2632import System.Environment

2733import System.Process (proc)

2834

29−import Obelisk.App (MonadObelisk)

35+import Obelisk.App (MonadInfallibleObelisk, MonadObelisk)

3036import Obelisk.CliApp

3137

3238-- | Where to put nix-build output

@@ -103,19 +109,27 @@ nixBuild cfg = withSpinner' ("Running nix-build on " <> desc) (Just $ const $ "B

103109-- tell the user what to do.

104110--

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

106−withNixRemoteCheck :: MonadObelisk m => m a -> m a

107−withNixRemoteCheck f = f `catch` \e@(ProcessFailed _ _) -> do

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

109− Just _ -> throwM e

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

111− True -> throwM e

112− False -> do

113− putLog Error "!!! "

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

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

116− putLog Error "!!! "

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

118− putLog Error "!!! "

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

120− putLog Error "!!! "

121− throwM e

112+withNixRemoteCheck

113+ :: MonadObelisk m

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

115+ -> m a

116+withNixRemoteCheck f = do

117+ status <- runExceptT f

118+ case status of

119+ 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

124+ 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