git.iko.soy/obelisk
on master help sign in
Add coloured terminal support

Introduce logError, logWarning and logInfo, correspondingly. Adjust the spinner to automatically log error on exceptoins. Introduce logErrorAndExit that uses exception (thus cleans up the spinner) in combination with `withCLI` that ensures that the error message is printed even if it was invoked from outside of any spinner. Wherever possible use logError/logWarning. Some uses of `fail` are left as-is for now, but they will need addressing eventually.

commit036135d7a2620ca47a6c5017ec4347676c02c933 authorSridhar Ratnakumar <srid@srid.ca> dateMon 7 May 2018, 17:49 (8 years ago) parenta32f1a5
8 files changed+91−31
compare with master
unifiedsplit
.gitignore+3 lib/command/obelisk-command.cabal+1 lib/command/src/Obelisk/Command.hs+4−4 lib/command/src/Obelisk/Command/CLI.hs+62−5 lib/command/src/Obelisk/Command/Nix.hs+3−2 lib/command/src/Obelisk/Command/Project.hs+4−6 lib/command/src/Obelisk/Command/Run.hs+5−2 lib/command/src/Obelisk/Command/Thunk.hs+9−12
.gitignore+3
@@ -3,6 +3,9 @@
33**/cabal.sandbox.config
44result
55
6+*.hi
7+*.o
8+
69TAGS
710tags
811ctags
lib/command/obelisk-command.cabal+1
@@ -7,6 +7,7 @@ library
77 hs-source-dirs: src
88 build-depends:
99 aeson
10+ , ansi-terminal
1011 , Cabal
1112 , aeson-pretty
1213 , base
lib/command/src/Obelisk/Command.hs+4−4
@@ -16,9 +16,9 @@ import GHC.StaticPtr
1616import Options.Applicative
1717import System.Environment
1818import System.FilePath
19−import System.IO
2019import System.Posix.Process (executeFile)
2120
21+import Obelisk.Command.CLI (putErrorAndExit, putWarning, runCLI)
2222import Obelisk.Command.Deploy
2323import Obelisk.Command.Project
2424import Obelisk.Command.Repl
@@ -153,7 +153,7 @@ parserPrefs = defaultPrefs
153153 }
154154
155155main :: IO ()
156−main = do
156+main = runCLI $ do
157157 myArgs <- getArgs
158158 --TODO: We'd like to actually use the parser to determine whether to hand off,
159159 --but in the case where this implementation of 'ob' doesn't support all
@@ -164,7 +164,7 @@ main = do
164164 case noHandoffPassed of
165165 False -> return ()
166166 --TODO: Use a proper logging system with log levels and whatnot
167− True -> hPutStrLn stderr "NOTICE: --no-handoff should only be passed once and as the first argument; ignoring"
167+ True -> putWarning "--no-handoff should only be passed once and as the first argument; ignoring"
168168 ob cmd
169169 handoffAndGo as = findProjectObeliskCommand "." >>= \case
170170 Nothing -> go as -- If not in a project, just run ourselves
@@ -195,7 +195,7 @@ ob = \case
195195 ObCommand_Watch component -> watch component
196196 ObCommand_Internal icmd -> case icmd of
197197 ObInternal_RunStaticIO k -> unsafeLookupStaticPtr @(IO ()) k >>= \case
198− Nothing -> fail $ "ObInternal_RunStaticIO: no such StaticKey: " <> show k
198+ Nothing -> putErrorAndExit $ "ObInternal_RunStaticIO: no such StaticKey: " <> (T.pack $ show k)
199199 Just p -> deRefStaticPtr p
200200--TODO: Clean up all the magic strings throughout this codebase
201201
lib/command/src/Obelisk/Command/CLI.hs+62−5
@@ -1,9 +1,21 @@
1+{-# LANGUAGE LambdaCase #-}
12module Obelisk.Command.CLI where
23
3−import Control.Exception (finally)
4+import Control.Exception (Exception, catch, handle, throw)
5+import Data.Text (Text)
6+import qualified Data.Text as T
7+import qualified Data.Text.IO as T
8+import Data.Typeable (Typeable)
9+import System.Exit (ExitCode (ExitFailure), exitWith)
410
11+import System.Console.ANSI
512import System.Console.Questioner (dots1Spinner, stopIndicator)
613
14+newtype AppError = AppError Text
15+ deriving (Show, Typeable)
16+
17+instance Exception AppError
18+
719withSpinner
820 :: String -- ^ Text to print alongside the spinner
921 -> Maybe String -- ^ Optional text to print at the end
@@ -11,8 +23,53 @@ withSpinner
1123 -> IO a
1224withSpinner s e f = do
1325 spinner <- dots1Spinner (1000 * 200) s
14− finally f $ do
26+
27+ -- Upon exception (typically raised by putErrorAndExit), stop the spinner, log the error and exit.
28+ result <- catch f $ \exc -> do
1529 stopIndicator spinner
16− case e of
17− Just exitMsg -> putStrLn exitMsg
18− Nothing -> return ()
30+ case exc of
31+ AppError err -> putError err
32+ exitWith $ ExitFailure 2
33+
34+ -- Upon no exceptions, stop the spinner and log the optional exit message.
35+ stopIndicator spinner
36+ case e of
37+ Just exitMsg -> putInfo $ T.pack exitMsg
38+ _ -> return ()
39+ return result
40+
41+data Level = Level_Normal | Level_Warning | Level_Error
42+
43+runCLI :: IO () -> IO ()
44+runCLI = handle $ \(AppError err) -> putError err
45+
46+-- | Prefer this over the alternative ways to exit the program with an error message as it automatically
47+-- takes care of cleaning on spinners.
48+-- TODO: Replace the uses of 'fail' throughout Stela to use this function.
49+putErrorAndExit :: Text -> IO ()
50+putErrorAndExit = throw . AppError
51+
52+putError :: Text -> IO ()
53+putError = putMsg Level_Error
54+
55+putWarning :: Text -> IO ()
56+putWarning = putMsg Level_Warning
57+
58+putInfo :: Text -> IO ()
59+putInfo = putMsg Level_Normal
60+
61+putMsg :: Level -> Text -> IO ()
62+putMsg level s = do
63+ setColor level
64+ T.putStrLn s
65+ setSGR [Reset]
66+
67+setColor :: Level -> IO ()
68+setColor = \case
69+ Level_Error -> do
70+ setSGR [SetColor Foreground Vivid Red]
71+ -- setSGR [SetColor Background Vivid White]
72+ Level_Warning -> do
73+ setSGR [SetColor Foreground Vivid Yellow]
74+ -- setSGR [SetColor Background Vivid Black]
75+ Level_Normal -> return ()
lib/command/src/Obelisk/Command/Nix.hs+3−2
@@ -1,4 +1,5 @@
11{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE OverloadedStrings #-}
23{-# LANGUAGE ScopedTypeVariables #-}
34module Obelisk.Command.Nix
45 ( nixBuild
@@ -14,7 +15,7 @@ import qualified Data.Text.IO as T
1415import System.Exit (ExitCode (ExitSuccess))
1516import System.Process (StdStream (CreatePipe), createProcess, proc, std_err, std_out, waitForProcess)
1617
17−import Obelisk.Command.CLI (withSpinner)
18+import Obelisk.Command.CLI (putErrorAndExit, withSpinner)
1819
1920-- | Where to put nix-build output
2021data OutLink
@@ -67,5 +68,5 @@ nixBuild cfg = do
6768 -- FIXME: We should interleave `out` and `err` in their original order?
6869 LBS.putStr =<< LBS.hGetContents out
6970 LBS.putStr =<< LBS.hGetContents err
70− fail "nix-build failed"
71+ putErrorAndExit "nix-build failed"
7172 T.unpack . T.strip <$> T.hGetContents out
lib/command/src/Obelisk/Command/Project.hs+4−6
@@ -18,10 +18,8 @@ import Data.Bits
1818import Data.Function (on)
1919import Data.Monoid
2020import qualified Data.Text as T
21−import qualified Data.Text.IO as T
2221import System.Directory
2322import System.FilePath
24−import System.IO
2523import System.Posix (FileStatus, UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)
2624import System.Posix.Files
2725import System.Process (CreateProcess, callProcess, createProcess_, cwd, proc, waitForProcess)
@@ -29,7 +27,7 @@ import System.Process (CreateProcess, callProcess, createProcess_, cwd, proc, wa
2927import GitHub.Data.GitData (Branch)
3028import GitHub.Data.Name (Name)
3129
32−import Obelisk.Command.CLI (withSpinner)
30+import Obelisk.Command.CLI (putError, putErrorAndExit, withSpinner)
3331import Obelisk.Command.Thunk
3432
3533--TODO: Make this module resilient to random exceptions
@@ -108,7 +106,7 @@ findProjectObeliskCommand target = do
108106 return $ Just $ obeliskCommandPkg </> "bin" </> "ob"
109107 (Nothing, _) -> return Nothing
110108 (Just projDir, _) -> do
111− T.hPutStr stderr $ T.unlines
109+ putError $ T.unlines
112110 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"
113111 , T.unlines $ fmap (T.pack . normalise) insecurePaths
114112 , "Please ensure that all of these directories are owned by you and are not writable by anyone else."
@@ -125,7 +123,7 @@ findProjectRoot target = do
125123
126124withProjectRoot :: FilePath -> (FilePath -> IO ()) -> IO ()
127125withProjectRoot target f = findProjectRoot target >>= \case
128− Nothing -> fail "Must be used inside of an Obelisk project"
126+ Nothing -> putErrorAndExit "Must be used inside of an Obelisk project"
129127 Just root -> f root
130128
131129-- | Walk from the current directory to the containing project's root directory,
@@ -186,7 +184,7 @@ projectShell root isPure shellName command = do
186184 , "shells." <> shellName
187185 , "--run", command
188186 ]
189− void $ withSpinner "Project shell ..." (Just "Finishing running project shell (runNixShellAttr)") $ do
187+ void $ withSpinner "Launching project shell ..." Nothing $ do
190188 waitForProcess ph
191189
192190setCwd :: Maybe FilePath -> CreateProcess -> CreateProcess
lib/command/src/Obelisk/Command/Run.hs+5−2
@@ -19,6 +19,9 @@ 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, putErrorAndExit)
2225
2326run :: IO ()
2427run = do
@@ -31,9 +34,9 @@ run = do
3134 Nothing -> Left pkg
3235 Just hsSrcDirs -> Right $ toList $ fmap (pkg </>) hsSrcDirs
3336 when (null hsSrcDirs) $
34− fail $ "No valid pkgs found in " <> intercalate ", " pkgs
37+ putErrorAndExit $ T.pack $ "No valid pkgs found in " <> intercalate ", " pkgs
3538 when (not (null pkgDirErrs)) $
36− putStrLn $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs
39+ putInfo $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs
3740 let dotGhci = unlines
3841 [ ":set args --quiet --port " <> show freePort
3942 , ":set -i" <> intercalate ":" (mconcat hsSrcDirs)
lib/command/src/Obelisk/Command/Thunk.hs+9−12
@@ -64,7 +64,7 @@ import System.Process (StdStream (CreatePipe), callProcess, createProcess, proc,
6464
6565import Development.Placeholders
6666
67−import Obelisk.Command.CLI (withSpinner)
67+import Obelisk.Command.CLI (putError, putErrorAndExit, putWarning, withSpinner)
6868
6969--TODO: Support symlinked thunk data
7070data ThunkData
@@ -120,7 +120,6 @@ commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
120120getNixSha256ForUriUnpacked :: URI -> IO NixSha256
121121getNixSha256ForUriUnpacked uri = do
122122 --TODO: Make this package depend on nix-prefetch-url properly
123− putStrLn "Calling nix-prefetch-url"
124123 let cmd = proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , show uri]
125124 (_, Just out, Just err, p) <- createProcess cmd
126125 { std_out = CreatePipe
@@ -133,7 +132,7 @@ getNixSha256ForUriUnpacked uri = do
133132 hPutStrLn stdout =<< hGetContents out
134133 hPutStrLn stderr =<< hGetContents err
135134 --TODO: actual error
136− fail $ "nix-prefetch-url"
135+ putErrorAndExit $ "nix-prefetch-url"
137136 T.strip <$> T.hGetContents out
138137
139138-- | Get the latest revision available from the given source
@@ -403,7 +402,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do
403402 --This should be guaranteed by the command argument parser.
404403 let cacheErrHandler e
405404 | isDoesNotExistError e = return Nothing -- expected from a cache miss
406− | otherwise = hPutStrLn stderr (displayException e) >> return Nothing
405+ | otherwise = putError (T.pack $ displayException e) >> return Nothing
407406 cacheDir = thunkDir </> ".attr-cache"
408407 cachePath = cacheDir </> attr <.> "out"
409408 createDirectoryIfMissing False cacheDir
@@ -416,7 +415,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do
416415 case cacheHit of
417416 Just c -> return c
418417 Nothing -> do
419− hPutStrLn stderr (mconcat [thunkDir, ": ", attr, " not cached, building ..."])
418+ putWarning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
420419 _ <- nixBuild $ def
421420 { _nixBuildConfig_target = Target
422421 { _target_path = thunkDir
@@ -448,9 +447,9 @@ nixBuildAttrWithCache exprPath attr = do
448447unpackThunk :: FilePath
449448 -> IO ()
450449unpackThunk thunkDir = readThunk thunkDir >>= \case
451− Left err -> fail $ "thunk unpack: " <> show err
450+ Left err -> putErrorAndExit $ "thunk unpack: " <> (T.pack $ show err)
452451 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
453− Right (ThunkData_Checkout _) -> fail "thunk unpack: thunk is already unpacked"
452+ Right (ThunkData_Checkout _) -> putErrorAndExit "thunk unpack: thunk is already unpacked"
454453 Right (ThunkData_Packed tptr) -> case _thunkPtr_source tptr of
455454 ThunkSource_GitHub s | (thunkParent, thunkName) <- splitFileName thunkDir -> withTempDirectory thunkParent thunkName $ \tmpRepo -> do
456455 mauth <- getHubAuth "github.com"
@@ -458,8 +457,7 @@ unpackThunk thunkDir = readThunk thunkDir >>= \case
458457 githubURI <- either throwIO (return . repoSshUrl) repoResult >>= \case
459458 Nothing -> fail "Cannot determine clone URI for thunk source"
460459 Just c -> return $ T.unpack $ getUrl c
461− putStrLn "Call hub"
462− withSpinner "hub:clone ..." (Just $ "Cloned " <> githubURI) $ do
460+ withSpinner "Cloning from GitHub ..." (Just $ "Cloned " <> githubURI) $ do
463461 callProcess "hub" --TODO: Depend on hub explicitly
464462 [ "clone"
465463 , "-n"
@@ -469,8 +467,7 @@ unpackThunk thunkDir = readThunk thunkDir >>= \case
469467 let obGitDir = tmpRepo </> ".git" </> "obelisk"
470468 --If this directory already exists then something is weird and we should fail
471469 createDirectory obGitDir
472− putStrLn "Call cp (orig-thunk)"
473− withSpinner "cp orig-thunk ..." (Just "Copied orig-thunk") $ do
470+ withSpinner "Copying thunk ..." Nothing $ do
474471 callProcess "cp"
475472 [ "-r"
476473 , "-T"
@@ -504,7 +501,7 @@ packThunk :: FilePath
504501 -> IO ()
505502packThunk thunkDir upstream = readThunk thunkDir >>= \case
506503 Left err -> fail $ "thunk pack: " <> show err
507− Right (ThunkData_Packed _) -> fail "pack: thunk is already packed"
504+ Right (ThunkData_Packed _) -> putErrorAndExit "pack: thunk is already packed"
508505 Right (ThunkData_Checkout _) -> do
509506 --Check whether the working directory is clean
510507 statusOutput <- readProcess "hub"