9f89eae · obelisk · git.iko.soy

git.iko.soy/obelisk

Introduce LoggingT, and revamp spinner/logging

Consequently introduce ObeliskT to wrap ReaderT (from #72) and LoggingT. All new code is kept in `Obelisk.CLI` namespace. - Use MVar lock to coordinate logging and spinning - When logging while a spinner is already running, we use the mvar to lock and clear the spinner first, before actually printing the log. This fixes corrupt output that can occur when using spinners. - Logging - Logging functions now use the logging-effect package. - Predefined severity levels from logging-effect - Retains the current behaviour (coloured logging) - `failWith` uses Fatal severity and colours accordingly. We should use this over `fail`. - Spinner -- Log handoffs -- withSpinner: removed the Maybe argument

commit9f89eae2cb70b6fec180022a73dcf1603fd3c626 authorSridhar Ratnakumar <srid@srid.ca> dateSat 12 May 2018, 11:08 (8 years ago) parent3ca76df

12 files changed+247−131

compare with master

unifiedsplit

lib/command/obelisk-command.cabal+3−1

@@ -22,6 +22,7 @@ library

2222 , hit

2323 , questioner

2424 , exceptions

25+ , logging-effect

2526 , mtl

2627 , network

2728 , network-uri

@@ -36,9 +37,10 @@ library

3637 , yaml

3738 exposed-modules:

3839 Obelisk.App

40+ Obelisk.CLI.Logging

41+ Obelisk.CLI.Spinner

3942 Obelisk.Command

4043 Obelisk.Command.Deploy

41− Obelisk.Command.CLI

4244 Obelisk.Command.Nix

4345 Obelisk.Command.Project

4446 Obelisk.Command.Repl

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

@@ -1,14 +1,37 @@

11{-# LANGUAGE ConstraintKinds #-}

22{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

34{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE StandaloneDeriving #-}

46module Obelisk.App where

6−import Control.Monad.Catch (MonadMask)

7−import Control.Monad.Reader (MonadIO, MonadReader)

8+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)

9+import Control.Monad.Log (LoggingT, MonadLog, runLoggingT)

10+import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, runReaderT)

11+

12+import Obelisk.CLI.Logging (LoggingConfig, Output, handleLog)

813

914data Obelisk = Obelisk

1015 { _obelisk_verbose :: Bool

16+ , _obelisk_noSpinner :: Bool

17+ , _obelisk_logging :: LoggingConfig

18+ }

19+

20+newtype ObeliskT m a = ObeliskT

21+ { unObeliskT :: ReaderT Obelisk (LoggingT Output m) a

1122 }

12− deriving (Eq, Show)

23+ deriving (Functor, Applicative, Monad, MonadIO)

24+

25+deriving instance MonadThrow m => MonadThrow (ObeliskT m)

26+deriving instance MonadCatch m => MonadCatch (ObeliskT m)

27+deriving instance MonadMask m => MonadMask (ObeliskT m)

28+

29+runObelisk :: MonadIO m => Obelisk -> ObeliskT m a -> m a

30+runObelisk c =

31+ flip runLoggingT loggingConfig

32+ . flip runReaderT c

33+ . unObeliskT

34+ where

35+ loggingConfig = handleLog $ _obelisk_logging c

1336

14−type MonadObelisk m = (MonadReader Obelisk m, MonadIO m, MonadMask m)

37+type MonadObelisk m = (MonadReader Obelisk m, MonadIO m, MonadMask m, MonadLog Output m)

lib/command/src/Obelisk/CLI/Logging.hsnew file+93

@@ -0,0 +1,93 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE MultiWayIf #-}

5+module Obelisk.CLI.Logging

6+ ( Severity (Error, Warning, Notice)

7+ , LoggingConfig (..)

8+ , Output (..)

9+ , failWith

10+ , putLog

11+ , handleLog

12+ ) where

13+

14+import Control.Concurrent.MVar (MVar, modifyMVar_)

15+import Control.Monad ((>=>))

16+import Control.Monad.Catch (MonadMask, bracket_)

17+import Control.Monad.IO.Class (liftIO)

18+import Control.Monad.Reader (MonadIO)

19+import Data.Text (Text)

20+import qualified Data.Text.IO as T

21+import System.Console.ANSI (Color (Red, Yellow), ColorIntensity (Vivid), ConsoleLayer (Foreground),

22+ SGR (Reset, SetColor), clearLine, setSGR)

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

24+import System.IO (hFlush, stdout)

25+

26+import Control.Monad.Log (MonadLog, Severity (..), WithSeverity (..), logMessage)

27+

28+

29+data LoggingConfig = LoggingConfig

30+ { _loggingConfig_level :: Severity -- TODO: Start using this.

31+ , _loggingConfig_lock :: MVar Bool -- Whether the last message was raw

32+ }

33+

34+data Output

35+ = Output_Log (WithSeverity Text) -- Regular logging message (with colors and newlines)

36+ | Output_Raw [String] -- Raw text messages to print using `putStr`

37+ | Output_ClearLine -- Clears the line

38+ deriving (Eq, Show, Ord)

39+

40+isRaw :: Output -> Bool

41+isRaw = \case

42+ Output_Raw _ -> True

43+ _ -> False

44+

45+handleLog :: MonadIO m => LoggingConfig -> Output -> m ()

46+handleLog c current = do

47+ let lock = _loggingConfig_lock c

48+ liftIO $ modifyMVar_ lock $ \raw -> do

49+ case (raw, current) of

50+ (True, Output_Log _) -> do

51+ -- If the last output was raw, clear the line prior to logging a non-raw

52+ -- message.

53+ handleLog' Output_ClearLine

54+ handleLog' current

55+ _ -> do

56+ handleLog' current

57+ return $ isRaw current

58+

59+handleLog' :: MonadIO m => Output -> m ()

60+handleLog' = \case

61+ Output_Log m -> liftIO $ writeLog m

62+ Output_Raw xs -> liftIO $ putStrs xs

63+ Output_ClearLine -> liftIO $ do

64+ -- Go to the first column and clear the whole line

65+ putStrs ["\r"]

66+ clearLine

67+ where

68+ -- putStr xs, and flush at the end.

69+ putStrs :: [String] -> IO ()

70+ putStrs = mapM_ putStr >=> const (hFlush stdout)

71+

72+-- | Safely log a message to the console. This is what we should use.

73+putLog :: MonadLog Output m => Severity -> Text -> m ()

74+putLog sev = logMessage . Output_Log . WithSeverity sev

75+

76+-- | Like `putLog Error` but also abrupts the program.

77+failWith :: (MonadIO m, MonadLog Output m) => Text -> m a

78+failWith s = do

79+ putLog Alert s

80+ liftIO $ exitWith $ ExitFailure 2

81+

82+-- | Write log to stdout with colors

83+-- TODO: Disable colours when not on interactive terminal

84+writeLog :: (MonadIO m, MonadMask m) => WithSeverity Text -> m ()

85+writeLog (WithSeverity severity s) = case sevColor severity of

86+ Just setColor -> bracket_ setColor reset $ liftIO (T.putStrLn s)

87+ Nothing -> liftIO $ T.putStrLn s

88+ where

89+ reset = liftIO $ setSGR [Reset]

90+ sevColor sev = if

91+ | sev <= Error -> Just $ liftIO $ setSGR [SetColor Foreground Vivid Red]

92+ | sev <= Warning -> Just $ liftIO $ setSGR [SetColor Foreground Vivid Yellow]

93+ | otherwise -> Nothing

lib/command/src/Obelisk/CLI/Spinner.hsnew file+34

@@ -0,0 +1,34 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE MultiParamTypeClasses #-}

3+module Obelisk.CLI.Spinner where

5+import Control.Concurrent (forkIO, killThread, threadDelay)

6+import Control.Monad (forM_)

7+import Control.Monad.Catch (MonadMask, bracket)

8+import Control.Monad.IO.Class (liftIO)

9+import Control.Monad.Log (MonadLog, logMessage, runLoggingT)

10+import Control.Monad.Reader (MonadIO)

11+import Data.Text (Text)

12+import qualified Data.Text as T

13+

14+import Obelisk.CLI.Logging (LoggingConfig, Output (..), handleLog)

15+

16+-- | Run an action with a CLI spinner. You should use the more convenient

17+-- `Obelisk.Command.Utils.withSpinner` instead.

18+withSpinner'

19+ :: (MonadIO m, MonadMask m, MonadLog Output m)

20+ => LoggingConfig -> Text -> m a -> m a

21+withSpinner' c s = bracket run cleanup . const

22+ where

23+ -- TODO: Can we obviate passing LoggingConfig just to use forkIO?

24+ run = liftIO $ forkIO $ flip runLoggingT (handleLog c) $ do

25+ forM_ (cycle spinner1) $ \e -> do

26+ logMessage $ Output_Raw ["\r", [e], " ", T.unpack s]

27+ delay

28+ cleanup tid = do

29+ liftIO $ killThread tid

30+ logMessage Output_ClearLine

31+ delay = liftIO $ threadDelay 100000 -- A shorter delay ensures that we update promptly.

32+

33+spinner1 :: String

34+spinner1 = "◐◓◑◒"

lib/command/src/Obelisk/Command.hs+47−14

@@ -7,9 +7,10 @@

77{-# LANGUAGE TypeApplications #-}

88module Obelisk.Command where

10+import Control.Concurrent (newMVar, threadDelay)

1011import Control.Monad

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

12−import Control.Monad.Reader (runReaderT)

13+import Control.Monad.Log

1314import qualified Data.Binary as Binary

1415import qualified Data.ByteString.Base16 as Base16

1516import qualified Data.ByteString.Lazy as LBS

@@ -21,15 +22,17 @@ import GHC.StaticPtr

2122import Options.Applicative

2223import System.Environment

2324import System.FilePath

25+import System.IO (hIsTerminalDevice, stdout)

2426import System.Posix.Process (executeFile)

2527

2628import Obelisk.App

27−import Obelisk.Command.CLI (failWith, putWarning)

29+import Obelisk.CLI.Logging (LoggingConfig (LoggingConfig), Severity (..), failWith, putLog)

2830import Obelisk.Command.Deploy

2931import Obelisk.Command.Project

3032import Obelisk.Command.Repl

3133import Obelisk.Command.Run

3234import Obelisk.Command.Thunk

35+import Obelisk.Command.Utils (withSpinner)

3336

3437data Args = Args

3538 { _args_noHandOffPassed :: Bool

@@ -73,6 +76,7 @@ data ObCommand

7376

7477data ObInternal

7578 = ObInternal_RunStaticIO StaticKey

79+ | ObInternal_TestLogging

7680

7781inNixShell' :: MonadObelisk m => StaticPtr (IO ()) -> m ()

7882inNixShell' p = withProjectRoot "." $ \root -> do

@@ -129,6 +133,7 @@ data DeployInitOpts = DeployInitOpts

129133internalCommand :: Parser ObInternal

130134internalCommand = subparser $ mconcat

131135 [ command "run-static-io" $ info (ObInternal_RunStaticIO <$> argument (eitherReader decodeStaticKey) (action "static-key")) mempty

136+ , command "testlog" $ info (pure ObInternal_TestLogging) mempty

132137 ]

133138

134139--TODO: Result should provide normalised path and also original user input for error reporting.

@@ -170,27 +175,43 @@ parserPrefs = defaultPrefs

170175 { prefShowHelpOnEmpty = True

171176 }

172177

178+-- | Are we on a terminal with active user interaction?

179+isInteractiveTerm :: IO Bool

180+isInteractiveTerm = do

181+ isTerm <- hIsTerminalDevice stdout

182+ -- Running in bash/fish/zsh completion

183+ inShellCompletion <- liftIO $ isInfixOf "completion" . unwords <$> getArgs

184+ return $ isTerm && not inShellCompletion

185+

173186main :: IO ()

174187main = do

175− myArgs <- getArgs

176188 -- We are not passing this as cli argument (--verbose) because run-static-io does not

177189 -- pass along the cli arguments to recursive obelisks.

178− obeliskConfig <- Obelisk . maybe False read <$> lookupEnv "VERBOSE"

190+ verbose <- maybe False read <$> lookupEnv "VERBOSE"

191+ noSpinner <- not <$> isInteractiveTerm

192+ loggingConfig <- LoggingConfig Debug <$> newMVar False

193+ let obeliskConfig = Obelisk verbose noSpinner loggingConfig

194+ runObelisk obeliskConfig $ ObeliskT main'

195+

196+main' :: MonadObelisk m => m ()

197+main' = do

198+ myArgs <- liftIO getArgs

179199 --TODO: We'd like to actually use the parser to determine whether to hand off,

180200 --but in the case where this implementation of 'ob' doesn't support all

181201 --arguments being passed along, this could fail. For now, we don't bother

182202 --with optparse-applicative until we've done the handoff.

183203 let go as = do

184− args' <- handleParseResult (execParserPure parserPrefs argsInfo as)

204+ args' <- liftIO $ handleParseResult (execParserPure parserPrefs argsInfo as)

185205 case _args_noHandOffPassed args' of

186206 False -> return ()

187− True -> putWarning "--no-handoff should only be passed once and as the first argument; ignoring"

188− runReaderT (ob $ _args_command args') obeliskConfig

189− handoffAndGo as = runReaderT (findProjectObeliskCommand ".") obeliskConfig >>= \case

207+ True -> putLog Warning "--no-handoff should only be passed once and as the first argument; ignoring"

208+ ob $ _args_command args'

209+ handoffAndGo as = findProjectObeliskCommand "." >>= \case

190210 Nothing -> go as -- If not in a project, just run ourselves

191211 Just impl -> do

192212 -- Invoke the real implementation, using --no-handoff to prevent infinite recursion

193− executeFile impl False ("--no-handoff" : myArgs) Nothing

213+ putLog Notice $ "Handing off to " <> T.pack impl

214+ liftIO $ executeFile impl False ("--no-handoff" : myArgs) Nothing

194215 case myArgs of

195216 "--no-handoff" : as -> go as -- If we've been told not to hand off, don't hand off

196217 a:as -- Otherwise bash completion would always hand-off even if the user isn't trying to

@@ -225,17 +246,29 @@ ob = \case

225246 ObCommand_Repl component -> runRepl component

226247 ObCommand_Watch component -> watch component

227248 ObCommand_Internal icmd -> case icmd of

228− ObInternal_RunStaticIO k -> liftIO $ unsafeLookupStaticPtr @(IO ()) k >>= \case

249+ ObInternal_RunStaticIO k -> liftIO (unsafeLookupStaticPtr @(IO ()) k) >>= \case

229250 Nothing -> failWith $ "ObInternal_RunStaticIO: no such StaticKey: " <> T.pack (show k)

230− Just p -> deRefStaticPtr p

251+ Just p -> liftIO $ deRefStaticPtr p

252+ ObInternal_TestLogging -> do -- TODO: Remove this command once thoroughly satisfied with logging/spinner.

253+ putLog Notice "We are going to start a spinner and log at the same time"

254+ withSpinner "Just spinning!" $ do

255+ liftIO $ threadDelay 1000000

256+ putLog Error "Some user error while spinning"

257+ liftIO $ threadDelay 1000000

258+ putLog Notice "This is some info mesage"

259+ putLog Warning "And now a warning as well"

260+ liftIO $ threadDelay 1000000

261+ -- failWith "Failing inside spinner"

262+ putLog Notice "Done spinning."

263+ putLog Warning "Going to fail now..."

264+ failWith "This is fail message"

265+

231266--TODO: Clean up all the magic strings throughout this codebase

232267

233268encodeStaticKey :: StaticKey -> String

234269encodeStaticKey = T.unpack . decodeUtf8 . Base16.encode . LBS.toStrict . Binary.encode

235270

236−-- TODO: This function should use `failWith` instead of `fail` so as to be consistent with the way obelisk

237−-- outputs in the rest of the codebase. However `failWith` returns `IO a`, so that involves revisiting

238−-- this function and thinking of how best to raise errors from pure (non-IO) functions.

271+-- TODO: Use failWith in place of fail to be consistent.

239272decodeStaticKey :: String -> Either String StaticKey

240273decodeStaticKey s = case Base16.decode $ encodeUtf8 $ T.pack s of

241274 (b, "") -> case Binary.decodeOrFail $ LBS.fromStrict b of

lib/command/src/Obelisk/Command/CLI.hsdeleted−81

@@ -1,81 +0,0 @@

1−{-# LANGUAGE FlexibleContexts #-}

2−{-# LANGUAGE LambdaCase #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−module Obelisk.Command.CLI where

5−

6−import Control.Monad.Catch (MonadThrow, finally, throwM)

7−import Control.Monad.IO.Class (liftIO)

8−import Control.Monad.Reader (MonadIO, asks)

9−import Data.List (isInfixOf)

10−import Data.Text (Text)

11−import qualified Data.Text as T

12−import qualified Data.Text.IO as T

13−import GHC.IO.Handle.FD (stdout)

14−import System.Environment (getArgs)

15−import System.IO (hFlush, hIsTerminalDevice)

16−

17−import System.Console.ANSI

18−import System.Console.Questioner (dots1Spinner, stopIndicator)

19−

20−import Obelisk.App (MonadObelisk, _obelisk_verbose)

21−

22−-- TODO: This doesn't handle the put* line of functions below, in that: when we print anything while the

23−-- spinner is already running, it won't appear correctly in the terminal. The exception is `failWith` which

24−-- raises an exception (that gets handled properly here). One solution to fix this problem is to run a

25−-- singleton spinner thread and interact with it in order to print something.

26−withSpinner

27− :: MonadObelisk m

28− => Text -- ^ Text to print alongside the spinner

29− -> Maybe Text -- ^ Optional text to print at the end

30− -> m a -- ^ Action to run and wait for

31− -> m a

32−withSpinner s e f = do

33− verbose <- asks _obelisk_verbose

34− isTerm <- liftIO $ hIsTerminalDevice stdout

35− -- When running in shell completion, disable the spinner.

36− inBashCompletion <- liftIO $ isInfixOf "completion" . unwords <$> getArgs

37− let spinnerDisabled = not isTerm || inBashCompletion || verbose

38− case spinnerDisabled of

39− True -> do

40− putInfo s

41− f

42− False -> do

43− spinner <- liftIO $ dots1Spinner (1000 * 200) $ T.unpack s

44− result <- finally f $ do

45− liftIO $ stopIndicator spinner

46− case e of

47− Just exitMsg -> putInfo exitMsg

48− Nothing -> liftIO $ hFlush stdout

49− return result

50−

51−data Level = Level_Normal | Level_Warning | Level_Error

52− deriving (Bounded, Enum, Eq, Ord, Show)

53−

54−-- TODO: Handle this error cleanly when evaluating outside of `withSpinner` (eg: runCLI)

55−failWith :: MonadThrow m => Text -> m a

56−failWith = throwM . userError . T.unpack

57−

58−putError :: MonadIO m => Text -> m ()

59−putError = liftIO . putMsg Level_Error

60−

61−putWarning :: MonadIO m => Text -> m ()

62−putWarning = liftIO . putMsg Level_Warning

63−

64−putInfo :: MonadIO m => Text -> m ()

65−putInfo = liftIO . putMsg Level_Normal

66−

67−putMsg :: MonadIO m => Level -> Text -> m ()

68−putMsg level s = liftIO $ do

69− setColor level

70− finally (T.putStrLn s) $

71− setSGR [Reset]

72−

73−setColor :: Level -> IO ()

74−setColor = \case

75− Level_Error -> do

76− setSGR [SetColor Foreground Vivid Red]

77− -- setSGR [SetColor Background Vivid White]

78− Level_Warning -> do

79− setSGR [SetColor Foreground Vivid Yellow]

80− -- setSGR [SetColor Background Vivid Black]

81− Level_Normal -> return ()

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

@@ -18,7 +18,7 @@ import System.Posix.Files

1818import System.Process

1919

2020import Obelisk.App (MonadObelisk)

21−import Obelisk.Command.CLI (failWith)

21+import Obelisk.CLI.Logging (failWith)

2222import Obelisk.Command.Nix

2323import Obelisk.Command.Thunk

2424import Obelisk.Command.Utils

lib/command/src/Obelisk/Command/Nix.hs+6−5

@@ -21,7 +21,8 @@ import System.Exit (ExitCode (ExitSuccess))

2121import System.Process (StdStream (CreatePipe), createProcess, proc, std_err, std_out, waitForProcess)

2222

2323import Obelisk.App (MonadObelisk)

24−import Obelisk.Command.CLI (failWith, withSpinner)

24+import Obelisk.CLI.Logging (failWith)

25+import Obelisk.Command.Utils (withSpinner)

2526

2627-- | Where to put nix-build output

2728data OutLink

@@ -76,12 +77,12 @@ nixBuild cfg = do

7677 , std_err = CreatePipe

7778 }

7879 let msg = T.pack $ "Running nix-build [" <> _target_path (_nixBuildConfig_target cfg) <> "] ..."

79− withSpinner msg Nothing $ do

80− liftIO $ waitForProcess p >>= \case

80+ withSpinner msg $ do

81+ liftIO (waitForProcess p) >>= \case

8182 ExitSuccess -> return ()

8283 _ -> do

8384 -- FIXME: We should interleave `out` and `err` in their original order?

84− LBS.putStr =<< LBS.hGetContents out

85− LBS.putStr =<< LBS.hGetContents err

85+ liftIO $ LBS.putStr =<< LBS.hGetContents out

86+ liftIO $ LBS.putStr =<< LBS.hGetContents err

8687 failWith "nix-build failed"

8788 liftIO $ T.unpack . T.strip <$> T.hGetContents out

lib/command/src/Obelisk/Command/Project.hs+5−5

@@ -29,10 +29,9 @@ import GitHub.Data.GitData (Branch)

2929import GitHub.Data.Name (Name)

3030

3131import Obelisk.App (MonadObelisk)

32−import Obelisk.Command.CLI (failWith, putError, withSpinner)

32+import Obelisk.CLI.Logging (Severity (..), failWith, putLog)

3333import Obelisk.Command.Thunk

34−import Obelisk.Command.Utils (cp)

35−

34+import Obelisk.Command.Utils (cp, withSpinner)

3635--TODO: Make this module resilient to random exceptions

3736

3837--TODO: Don't hardcode this

@@ -71,7 +70,7 @@ initProject source = do

7170 _ <- nixBuildAttrWithCache implDir "command"

7271 --TODO: We should probably handoff to the impl here

7372 skeleton <- nixBuildAttrWithCache implDir "skeleton" --TODO: I don't think there's actually any reason to cache this

74− withSpinner "Copying project skeleton ..." (Just "Copied project skeleton.") $ do

73+ withSpinner "Copying project skeleton ..." $ do

7574 liftIO $ cp --TODO: Make this package depend on nix-prefetch-url properly

7675 [ "-r"

7776 , "--no-preserve=mode"

@@ -79,6 +78,7 @@ initProject source = do

7978 , skeleton </> "."

8079 , "."

8180 ]

81+ putLog Notice "Created project skeleton."

8282 let configDir = "config"

8383 liftIO $ createDirectory configDir

8484 liftIO $ mapM_ (createDirectory . (configDir </>)) ["backend", "common", "frontend"]

@@ -102,7 +102,7 @@ findProjectObeliskCommand target = do

102102 return $ Just $ obeliskCommandPkg </> "bin" </> "ob"

103103 (Nothing, _) -> return Nothing

104104 (Just projDir, _) -> do

105− putError $ T.unlines

105+ putLog Error $ T.unlines

106106 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"

107107 , T.unlines $ fmap (T.pack . normalise) insecurePaths

108108 , "Please ensure that all of these directories are owned by you and are not writable by anyone else."

lib/command/src/Obelisk/Command/Run.hs+2−5

@@ -19,9 +19,6 @@ import System.Directory

1919import System.FilePath

2020import System.IO.Temp (withSystemTempDirectory)

2121import System.Process (callCommand)

22−import qualified Data.Text as T

23−

24−import Obelisk.Command.CLI (putInfo, failWith)

2522

2623run :: IO ()

2724run = do

@@ -34,9 +31,9 @@ run = do

3431 Nothing -> Left pkg

3532 Just hsSrcDirs -> Right $ toList $ fmap (pkg </>) hsSrcDirs

3633 when (null hsSrcDirs) $

37− failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " pkgs

34+ fail $ "No valid pkgs found in " <> intercalate ", " pkgs

3835 when (not (null pkgDirErrs)) $

39− putInfo $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs

36+ putStrLn $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs

4037 let dotGhci = unlines

4138 [ ":set args --quiet --port " <> show freePort

4239 , ":set -i" <> intercalate ":" (mconcat hsSrcDirs)

lib/command/src/Obelisk/Command/Thunk.hs+18−15

@@ -30,7 +30,8 @@ import Control.Exception (displayException, throwIO)

3030import Control.Monad

3131import Control.Monad.Catch (handle)

3232import Control.Monad.Except

33−import Data.Aeson as Aeson

33+import Data.Aeson (decode, (.=))

34+import qualified Data.Aeson as Aeson

3435import Data.Aeson.Encode.Pretty

3536import qualified Data.ByteString.Lazy as LBS

3637import Data.Default

@@ -69,8 +70,8 @@ import System.Process (StdStream (CreatePipe), callProcess, createProcess, proc,

6970

7071import Development.Placeholders

7172import Obelisk.App (MonadObelisk)

72−import Obelisk.Command.CLI (failWith, putError, putWarning, withSpinner)

73−import Obelisk.Command.Utils

73+import Obelisk.CLI.Logging (Severity (..), failWith, putLog)

74+import Obelisk.Command.Utils (callProcessNixShell, checkGitCleanStatus, cp, withSpinner)

7475

7576--TODO: Support symlinked thunk data

7677data ThunkData

@@ -123,6 +124,7 @@ data GitSource = GitSource

123124commitNameToRef :: Name Commit -> Ref

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

125126

127+-- TODO: Use spinner here.

126128getNixSha256ForUriUnpacked :: URI -> IO NixSha256

127129getNixSha256ForUriUnpacked uri = do

128130 --TODO: Make this package depend on nix-prefetch-url properly

@@ -138,7 +140,7 @@ getNixSha256ForUriUnpacked uri = do

138140 hPutStrLn stdout =<< hGetContents out

139141 hPutStrLn stderr =<< hGetContents err

140142 --TODO: actual error

141− failWith $ "nix-prefetch-url"

143+ fail "nix-prefetch-url"

142144 T.strip <$> T.hGetContents out

143145

144146-- | Get the latest revision available from the given source

@@ -410,7 +412,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do

410412 --This should be guaranteed by the command argument parser.

411413 let cacheErrHandler e

412414 | isDoesNotExistError e = return Nothing -- expected from a cache miss

413− | otherwise = putError (T.pack $ displayException e) >> return Nothing

415+ | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing

414416 cacheDir = thunkDir </> ".attr-cache"

415417 cachePath = cacheDir </> attr <.> "out"

416418 liftIO $ createDirectoryIfMissing False cacheDir

@@ -423,7 +425,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do

423425 case cacheHit of

424426 Just c -> return c

425427 Nothing -> do

426− putWarning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]

428+ putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]

427429 _ <- nixBuild $ def

428430 { _nixBuildConfig_target = Target

429431 { _target_path = thunkDir

@@ -467,19 +469,20 @@ unpackThunk thunkDir = readThunk thunkDir >>= \case

467469 mauth <- liftIO $ getHubAuth "github.com"

468470 repoResult <- liftIO $ executeRequestMaybe mauth $ repositoryR (_gitHubSource_owner s) (_gitHubSource_repo s)

469471 githubURI <- liftIO $ either throwIO (return . repoSshUrl) repoResult >>= \case

470− Nothing -> failWith "Cannot determine clone URI for thunk source"

472+ Nothing -> fail "Cannot determine clone URI for thunk source"

471473 Just c -> return $ T.unpack $ getUrl c

472− withSpinner "Cloning from GitHub ..." (Just $ "Cloned " <> T.pack githubURI) $ do

474+ withSpinner "Cloning from GitHub ..." $ do

473475 liftIO $ callProcess "hub" --TODO: Depend on hub explicitly

474476 [ "clone"

475477 , "-n"

476478 , githubURI

477479 , tmpRepo

478480 ]

481+ putLog Notice $ "Cloned " <> T.pack githubURI

479482 let obGitDir = tmpRepo </> ".git" </> "obelisk"

480483 --If this directory already exists then something is weird and we should fail

481484 liftIO $ createDirectory obGitDir

482− withSpinner "Copying thunk ..." Nothing $ do

485+ withSpinner "Copying thunk ..." $ do

483486 liftIO $ cp

484487 [ "-r"

485488 , "-T"

@@ -534,7 +537,7 @@ getThunkPtr thunkDir upstream = do

534537 False -> do

535538 statusDebug <- readProcess "hub"

536539 [ "-C", thunkDir, "status", "--ignored" ] ""

537− failWith $ T.pack $ unlines $

540+ fail $ unlines $

538541 [ "thunk pack: thunk checkout contains unsaved modifications"

539542 , "git status:"

540543 ] ++ lines statusDebug

@@ -544,7 +547,7 @@ getThunkPtr thunkDir upstream = do

544547 stashOutput <- readProcess "hub" [ "-C", thunkDir, "stash", "list" ] ""

545548 case null stashOutput of

546549 False -> do

547− failWith $ T.pack $ unlines $

550+ fail $ unlines $

548551 [ "thunk pack: thunk checkout has stashes"

549552 , "git stash list:"

550553 ] ++ lines stashOutput

@@ -558,7 +561,7 @@ getThunkPtr thunkDir upstream = do

558561 remotes <- lines <$> readProcess "hub" [ "-C", thunkDir, "remote" ] ""

559562 --Check that the upstream specified actually exists

560563 case L.find (== upstream) remotes of

561− Nothing -> failWith $ T.pack $ "thunk pack: upstream " <> upstream <> " does not exist"

564+ Nothing -> fail $ "thunk pack: upstream " <> upstream <> " does not exist"

562565 Just _ -> return ()

563566 -- iterate over cartesian product

564567 forM_ repoHeads $ \hd -> do

@@ -572,7 +575,7 @@ getThunkPtr thunkDir upstream = do

572575 , "remotes/" <> rm <> "/" <> hd

573576 ] ""

574577 case remoteMergeRev == localRev of

575− False -> failWith $ T.pack $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]

578+ False -> fail $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]

576579 True -> return ()

577580

578581 --We assume it's safe to pack the thunk at this point

@@ -585,7 +588,7 @@ getThunkPtr thunkDir upstream = do

585588 mRemoteUri = parseURIReference remoteUri'

586589 <|> parseSshShorthand remoteUri'

587590 thunkPtr <- case mRemoteUri of

588− Nothing -> failWith $ T.pack uriParseFailure

591+ Nothing -> fail uriParseFailure

589592 Just remoteUri -> do

590593 refs <- fmap (refsToTuples . words) . lines <$> readProcess "hub"

591594 [ "-C"

@@ -645,7 +648,7 @@ getThunkPtr thunkDir upstream = do

645648 case uriScheme u of

646649 "https:" -> return ()

647650 "git:" -> return ()

648− _ -> failWith "thunk pack: obelisk currently only supports https and git protocols for non-GitHub remotes"

651+ _ -> fail "thunk pack: obelisk currently only supports https and git protocols for non-GitHub remotes"

649652 $notImplemented

650653 parseSshShorthand uri' = do

651654 -- This is what git does to check that the remote

lib/command/src/Obelisk/Command/Utils.hs+11

@@ -1,11 +1,17 @@

1+{-# LANGUAGE FlexibleContexts #-}

12{-# LANGUAGE OverloadedStrings #-}

23module Obelisk.Command.Utils where

5+import Control.Monad.Reader (asks)

46import qualified Data.List as L

57import Data.Semigroup ((<>))

8+import Data.Text (Text)

69import qualified Data.Text as T

710import System.Process

811

12+import Obelisk.App (MonadObelisk, _obelisk_logging)

13+import Obelisk.CLI.Spinner (withSpinner')

14+

915-- Check whether the working directory is clean

1016checkGitCleanStatus :: FilePath -> IO Bool

1117checkGitCleanStatus fp = do

@@ -30,3 +36,8 @@ callProcessNixShell pkgs cmd args = callProcess "nix-shell" $

3036

3137cp :: [String] -> IO ()

3238cp = callProcessNixShell ["coreutils"] "cp"

39+

40+withSpinner :: MonadObelisk m => Text -> m a -> m a

41+withSpinner s a = do

42+ c <- asks _obelisk_logging

43+ withSpinner' c s a