git.iko.soy/obelisk
on master help sign in
Merge pull request #64 from srid/sr-spinner

Add spinner; start using coloured output

commitacb1be43beb95bd9b9376b391ffe85a9966afdcb authorLuigy Leon <luichi.19@gmail.com> dateThu 10 May 2018, 13:14 (8 years ago) parent7834a393ea07aa
8 files changed+151−65
compare with master
unifiedsplit
lib/command/obelisk-command.cabal+3 lib/command/src/Obelisk/Command.hs+12−12 lib/command/src/Obelisk/Command/CLI.hs+70 lib/command/src/Obelisk/Command/Nix.hs+10−4 lib/command/src/Obelisk/Command/Project.hs+13−14 lib/command/src/Obelisk/Command/Run.hs+5−2 lib/command/src/Obelisk/Command/Thunk.hs+36−31 skeleton/common/src/Common/Api.hs+2−2
lib/command/obelisk-command.cabal+3
@@ -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
@@ -19,6 +20,7 @@ library
1920 , filepath
2021 , github
2122 , hit
23+ , questioner
2224 , mtl
2325 , network
2426 , network-uri
@@ -34,6 +36,7 @@ library
3436 exposed-modules:
3537 Obelisk.Command
3638 Obelisk.Command.Deploy
39+ Obelisk.Command.CLI
3740 Obelisk.Command.Nix
3841 Obelisk.Command.Project
3942 Obelisk.Command.Repl
lib/command/src/Obelisk/Command.hs+12−12
@@ -1,11 +1,9 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
33{-# LANGUAGE StaticPointers #-}
4−{-# LANGUAGE TemplateHaskell #-}
54{-# LANGUAGE TypeApplications #-}
65module Obelisk.Command where
76
8−import System.Process ()
97import Control.Monad
108import qualified Data.Binary as Binary
119import qualified Data.ByteString.Base16 as Base16
@@ -18,14 +16,14 @@ import GHC.StaticPtr
1816import Options.Applicative
1917import System.Environment
2018import System.FilePath
21−import System.IO
22−import System.Posix.Process
19+import System.Posix.Process (executeFile)
2320
24−import Obelisk.Command.Project
21+import Obelisk.Command.CLI (failWith, putWarning)
2522import Obelisk.Command.Deploy
26−import Obelisk.Command.Thunk
23+import Obelisk.Command.Project
2724import Obelisk.Command.Repl
2825import Obelisk.Command.Run
26+import Obelisk.Command.Thunk
2927import Obelisk.Command.Utils
3028
3129data Args = Args
@@ -176,8 +174,7 @@ main = do
176174 Args noHandoffPassed cmd <- handleParseResult (execParserPure parserPrefs argsInfo as)
177175 case noHandoffPassed of
178176 False -> return ()
179− --TODO: Use a proper logging system with log levels and whatnot
180− True -> hPutStrLn stderr "NOTICE: --no-handoff should only be passed once and as the first argument; ignoring"
177+ True -> putWarning "--no-handoff should only be passed once and as the first argument; ignoring"
181178 ob cmd
182179 handoffAndGo as = findProjectObeliskCommand "." >>= \case
183180 Nothing -> go as -- If not in a project, just run ourselves
@@ -198,7 +195,7 @@ ob = \case
198195 ObCommand_Deploy dc -> case dc of
199196 DeployCommand_Init deployOpts -> withProjectRoot "." $ \root -> do
200197 thunkPtr <- readThunk root >>= \case
201− Left err -> fail $ "thunk pack: " <> show err
198+ Left err -> failWith $ T.pack $ "thunk pack: " <> show err
202199 Right (ThunkData_Packed ptr) -> return ptr
203200 Right (ThunkData_Checkout (Just ptr)) -> return ptr
204201 Right (ThunkData_Checkout Nothing) ->
@@ -210,7 +207,7 @@ ob = \case
210207 DeployCommand_Push -> do
211208 checkGitCleanStatus "." >>= \case
212209 True -> return ()
213− False -> fail "ob push: Commit any changes to the deployment configuration before proceeding"
210+ False -> failWith "ob push: Commit any changes to the deployment configuration before proceeding"
214211 ObCommand_Run -> inNixShell' $ static run
215212 -- inNixShell ($(mkClosure 'ghcidAction) ())
216213 ObCommand_Thunk tc -> case tc of
@@ -221,17 +218,20 @@ ob = \case
221218 ObCommand_Watch component -> watch component
222219 ObCommand_Internal icmd -> case icmd of
223220 ObInternal_RunStaticIO k -> unsafeLookupStaticPtr @(IO ()) k >>= \case
224− Nothing -> fail $ "ObInternal_RunStaticIO: no such StaticKey: " <> show k
221+ Nothing -> failWith $ "ObInternal_RunStaticIO: no such StaticKey: " <> T.pack (show k)
225222 Just p -> deRefStaticPtr p
226223--TODO: Clean up all the magic strings throughout this codebase
227224
228225encodeStaticKey :: StaticKey -> String
229226encodeStaticKey = T.unpack . decodeUtf8 . Base16.encode . LBS.toStrict . Binary.encode
230227
228+-- TODO: This function should use `failWith` instead of `fail` so as to be consistent with the way obelisk
229+-- outputs in the rest of the codebase. However `failWith` returns `IO a`, so that involves revisiting
230+-- this function and thinking of how best to raise errors from pure (non-IO) functions.
231231decodeStaticKey :: String -> Either String StaticKey
232232decodeStaticKey s = case Base16.decode $ encodeUtf8 $ T.pack s of
233233 (b, "") -> case Binary.decodeOrFail $ LBS.fromStrict b of
234234 Right ("", _, a) -> pure a
235− Right _ -> fail $ "decodeStaticKey: Binary.decodeOrFail didn't consume all input"
235+ Right _ -> fail "decodeStaticKey: Binary.decodeOrFail didn't consume all input"
236236 Left (_, _, e) -> fail $ "decodeStaticKey: Binary.decodeOrFail failed: " <> show e
237237 _ -> fail $ "decodeStaticKey: could not decode hex string: " <> show s
lib/command/src/Obelisk/Command/CLI.hsnew file+70
@@ -0,0 +1,70 @@
1+{-# LANGUAGE LambdaCase #-}
2+module Obelisk.Command.CLI where
3+
4+import Control.Exception (finally)
5+import Data.List (isInfixOf)
6+import Data.Text (Text)
7+import qualified Data.Text as T
8+import qualified Data.Text.IO as T
9+import GHC.IO.Handle.FD (stdout)
10+import System.Environment (getArgs)
11+import System.IO (hIsTerminalDevice)
12+
13+import System.Console.ANSI
14+import System.Console.Questioner (dots1Spinner, stopIndicator)
15+
16+-- TODO: This doesn't handle the put* line of functions below, in that: when we print anything while the
17+-- spinner is already running, it won't appear correctly in the terminal. The exception is `failWith` which
18+-- raises an exception (that gets handled properly here). One solution to fix this problem is to run a
19+-- singleton spinner thread and interact with it in order to print something.
20+withSpinner
21+ :: String -- ^ Text to print alongside the spinner
22+ -> Maybe String -- ^ Optional text to print at the end
23+ -> IO a -- ^ Action to run and wait for
24+ -> IO a
25+withSpinner s e f = do
26+ isTerm <- hIsTerminalDevice stdout
27+ -- When running in shell completion, disable the spinner. TODO: Do this using ReaderT and config.
28+ inBashCompletion <- isInfixOf "completion" . unwords <$> getArgs
29+ case not isTerm || inBashCompletion of
30+ True -> f
31+ False -> do
32+ spinner <- dots1Spinner (1000 * 200) s
33+ result <- finally f $ do
34+ stopIndicator spinner
35+ case e of
36+ Just exitMsg -> putInfo $ T.pack exitMsg
37+ _ -> return ()
38+ return result
39+
40+data Level = Level_Normal | Level_Warning | Level_Error
41+ deriving (Bounded, Enum, Eq, Ord, Show)
42+
43+-- TODO: Handle this error cleanly when evaluating outside of `withSpinner` (eg: runCLI)
44+failWith :: Text -> IO a
45+failWith = ioError . userError . T.unpack
46+
47+putError :: Text -> IO ()
48+putError = putMsg Level_Error
49+
50+putWarning :: Text -> IO ()
51+putWarning = putMsg Level_Warning
52+
53+putInfo :: Text -> IO ()
54+putInfo = putMsg Level_Normal
55+
56+putMsg :: Level -> Text -> IO ()
57+putMsg level s = do
58+ setColor level
59+ T.putStrLn s
60+ setSGR [Reset]
61+
62+setColor :: Level -> IO ()
63+setColor = \case
64+ Level_Error -> do
65+ setSGR [SetColor Foreground Vivid Red]
66+ -- setSGR [SetColor Background Vivid White]
67+ Level_Warning -> do
68+ setSGR [SetColor Foreground Vivid Yellow]
69+ -- setSGR [SetColor Background Vivid Black]
70+ Level_Normal -> return ()
lib/command/src/Obelisk/Command/Nix.hs+10−4
@@ -1,4 +1,6 @@
11{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
24module Obelisk.Command.Nix
35 ( nixBuild
46 , NixBuildConfig (..)
@@ -8,10 +10,13 @@ module Obelisk.Command.Nix
810
911import qualified Data.ByteString.Lazy as LBS
1012import Data.Default
13+import Data.Monoid ((<>))
1114import qualified Data.Text as T
1215import qualified Data.Text.IO as T
13−import System.Exit
14−import System.Process
16+import System.Exit (ExitCode (ExitSuccess))
17+import System.Process (StdStream (CreatePipe), createProcess, proc, std_err, std_out, waitForProcess)
18+
19+import Obelisk.Command.CLI (failWith, withSpinner)
1520
1621-- | Where to put nix-build output
1722data OutLink
@@ -58,11 +63,12 @@ nixBuild cfg = do
5863 { std_out = CreatePipe
5964 , std_err = CreatePipe
6065 }
61− waitForProcess p >>= \case
66+ let msg = "Running nix-build [" <> _target_path (_nixBuildConfig_target cfg) <> "] ..."
67+ withSpinner msg Nothing $ waitForProcess p >>= \case
6268 ExitSuccess -> return ()
6369 _ -> do
6470 -- FIXME: We should interleave `out` and `err` in their original order?
6571 LBS.putStr =<< LBS.hGetContents out
6672 LBS.putStr =<< LBS.hGetContents err
67− fail "nix-build failed"
73+ failWith "nix-build failed"
6874 T.unpack . T.strip <$> T.hGetContents out
lib/command/src/Obelisk/Command/Project.hs+13−14
@@ -18,17 +18,16 @@ 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
27−import System.Process
25+import System.Process (CreateProcess, callProcess, createProcess_, cwd, proc, waitForProcess)
2826
2927import GitHub.Data.GitData (Branch)
3028import GitHub.Data.Name (Name)
3129
30+import Obelisk.Command.CLI (failWith, putError, withSpinner)
3231import Obelisk.Command.Thunk
3332
3433--TODO: Make this module resilient to random exceptions
@@ -69,13 +68,14 @@ initProject source = do
6968 _ <- nixBuildAttrWithCache implDir "command"
7069 --TODO: We should probably handoff to the impl here
7170 skeleton <- nixBuildAttrWithCache implDir "skeleton" --TODO: I don't think there's actually any reason to cache this
72− callProcess "cp" --TODO: Make this package depend on nix-prefetch-url properly
73− [ "-r"
74− , "--no-preserve=mode"
75− , "-T"
76− , skeleton </> "."
77− , "."
78− ]
71+ withSpinner "Copying project skeleton ..." (Just "Copied project skeleton.") $ do
72+ callProcess "cp" --TODO: Make this package depend on nix-prefetch-url properly
73+ [ "-r"
74+ , "--no-preserve=mode"
75+ , "-T"
76+ , skeleton </> "."
77+ , "."
78+ ]
7979 let configDir = "config"
8080 createDirectory configDir
8181 mapM_ (createDirectory . (configDir </>)) ["backend", "common", "frontend"]
@@ -99,7 +99,7 @@ findProjectObeliskCommand target = do
9999 return $ Just $ obeliskCommandPkg </> "bin" </> "ob"
100100 (Nothing, _) -> return Nothing
101101 (Just projDir, _) -> do
102− T.hPutStr stderr $ T.unlines
102+ putError $ T.unlines
103103 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"
104104 , T.unlines $ fmap (T.pack . normalise) insecurePaths
105105 , "Please ensure that all of these directories are owned by you and are not writable by anyone else."
@@ -116,7 +116,7 @@ findProjectRoot target = do
116116
117117withProjectRoot :: FilePath -> (FilePath -> IO ()) -> IO ()
118118withProjectRoot target f = findProjectRoot target >>= \case
119− Nothing -> fail "Must be used inside of an Obelisk project"
119+ Nothing -> failWith "Must be used inside of an Obelisk project"
120120 Just root -> f root
121121
122122-- | Walk from the current directory to the containing project's root directory,
@@ -177,8 +177,7 @@ projectShell root isPure shellName command = do
177177 , "shells." <> shellName
178178 , "--run", command
179179 ]
180− _ <- waitForProcess ph
181− return ()
180+ void $ waitForProcess ph
182181
183182setCwd :: Maybe FilePath -> CreateProcess -> CreateProcess
184183setCwd fp cp = cp { cwd = fp }
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, failWith)
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+ failWith $ 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+36−31
@@ -61,11 +61,14 @@ import System.IO
6161import System.IO.Error
6262import System.IO.Temp
6363import System.Posix (getSymbolicLinkStatus, modificationTime)
64−import System.Process
64+import System.Process (StdStream (CreatePipe), callProcess, createProcess, proc, readProcess, std_err,
65+ std_out, waitForProcess)
6566
6667import Development.Placeholders
6768import Obelisk.Command.Utils
6869
70+import Obelisk.Command.CLI (failWith, putError, putWarning, withSpinner)
71+
6972--TODO: Support symlinked thunk data
7073data ThunkData
7174 = ThunkData_Packed ThunkPtr
@@ -132,7 +135,7 @@ getNixSha256ForUriUnpacked uri = do
132135 hPutStrLn stdout =<< hGetContents out
133136 hPutStrLn stderr =<< hGetContents err
134137 --TODO: actual error
135− fail $ "nix-prefetch-url"
138+ failWith $ "nix-prefetch-url"
136139 T.strip <$> T.hGetContents out
137140
138141-- | Get the latest revision available from the given source
@@ -322,10 +325,10 @@ createThunkWithLatest target s = do
322325updateThunkToLatest :: FilePath -> IO ()
323326updateThunkToLatest target = do
324327 (overwrite, ptr) <- readThunk target >>= \case
325− Left err -> fail $ "thunk update: " <> show err
326− Right c -> return $ case c of
327− ThunkData_Packed t -> (target, t)
328− ThunkData_Checkout _ -> fail "cannot update an unpacked thunk"
328+ Left err -> failWith $ T.pack $ "thunk update: " <> show err
329+ Right c -> case c of
330+ ThunkData_Packed t -> return (target, t)
331+ ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
329332 let src = _thunkPtr_source ptr
330333 rev <- getLatestRev src
331334 overwriteThunk overwrite $ ThunkPtr
@@ -402,7 +405,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do
402405 --This should be guaranteed by the command argument parser.
403406 let cacheErrHandler e
404407 | isDoesNotExistError e = return Nothing -- expected from a cache miss
405− | otherwise = hPutStrLn stderr (displayException e) >> return Nothing
408+ | otherwise = putError (T.pack $ displayException e) >> return Nothing
406409 cacheDir = thunkDir </> ".attr-cache"
407410 cachePath = cacheDir </> attr <.> "out"
408411 createDirectoryIfMissing False cacheDir
@@ -415,7 +418,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do
415418 case cacheHit of
416419 Just c -> return c
417420 Nothing -> do
418− hPutStrLn stderr (mconcat [thunkDir, ": ", attr, " not cached, building ..."])
421+ putWarning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
419422 _ <- nixBuild $ def
420423 { _nixBuildConfig_target = Target
421424 { _target_path = thunkDir
@@ -447,31 +450,33 @@ nixBuildAttrWithCache exprPath attr = do
447450unpackThunk :: FilePath
448451 -> IO ()
449452unpackThunk thunkDir = readThunk thunkDir >>= \case
450− Left err -> fail $ "thunk unpack: " <> show err
453+ Left err -> failWith $ "thunk unpack: " <> (T.pack $ show err)
451454 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
452− Right (ThunkData_Checkout _) -> fail "thunk unpack: thunk is already unpacked"
455+ Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"
453456 Right (ThunkData_Packed tptr) -> case _thunkPtr_source tptr of
454457 ThunkSource_GitHub s | (thunkParent, thunkName) <- splitFileName thunkDir -> withTempDirectory thunkParent thunkName $ \tmpRepo -> do
455458 mauth <- getHubAuth "github.com"
456459 repoResult <- executeRequestMaybe mauth $ repositoryR (_gitHubSource_owner s) (_gitHubSource_repo s)
457460 githubURI <- either throwIO (return . repoSshUrl) repoResult >>= \case
458− Nothing -> fail "Cannot determine clone URI for thunk source"
461+ Nothing -> failWith "Cannot determine clone URI for thunk source"
459462 Just c -> return $ T.unpack $ getUrl c
460− callProcess "hub" --TODO: Depend on hub explicitly
461− [ "clone"
462− , "-n"
463− , githubURI
464− , tmpRepo
465− ]
463+ withSpinner "Cloning from GitHub ..." (Just $ "Cloned " <> githubURI) $ do
464+ callProcess "hub" --TODO: Depend on hub explicitly
465+ [ "clone"
466+ , "-n"
467+ , githubURI
468+ , tmpRepo
469+ ]
466470 let obGitDir = tmpRepo </> ".git" </> "obelisk"
467471 --If this directory already exists then something is weird and we should fail
468472 createDirectory obGitDir
469− callProcess "cp"
470− [ "-r"
471− , "-T"
472− , thunkDir </> "."
473− , obGitDir </> "orig-thunk"
474− ]
473+ withSpinner "Copying thunk ..." Nothing $ do
474+ callProcess "cp"
475+ [ "-r"
476+ , "-T"
477+ , thunkDir </> "."
478+ , obGitDir </> "orig-thunk"
479+ ]
475480 let checkoutOptions = concat
476481 [ ["-C", tmpRepo]
477482 , pure "checkout"
@@ -498,8 +503,8 @@ packThunk :: FilePath
498503 -> String
499504 -> IO ()
500505packThunk thunkDir upstream = readThunk thunkDir >>= \case
501− Left err -> fail $ "thunk pack: " <> show err
502− Right (ThunkData_Packed _) -> fail "pack: thunk is already packed"
506+ Left err -> failWith $ T.pack $ "thunk pack: " <> show err
507+ Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
503508 Right (ThunkData_Checkout _) -> do
504509 thunkPtr <- getThunkPtr thunkDir upstream
505510 callProcess "rm"
@@ -515,7 +520,7 @@ getThunkPtr thunkDir upstream = do
515520 False -> do
516521 statusDebug <- readProcess "hub"
517522 [ "-C", thunkDir, "status", "--ignored" ] ""
518− fail $ unlines $
523+ failWith $ T.pack $ unlines $
519524 [ "thunk pack: thunk checkout contains unsaved modifications"
520525 , "git status:"
521526 ] ++ lines statusDebug
@@ -525,7 +530,7 @@ getThunkPtr thunkDir upstream = do
525530 stashOutput <- readProcess "hub" [ "-C", thunkDir, "stash", "list" ] ""
526531 case null stashOutput of
527532 False -> do
528− fail $ unlines $
533+ failWith $ T.pack $ unlines $
529534 [ "thunk pack: thunk checkout has stashes"
530535 , "git stash list:"
531536 ] ++ lines stashOutput
@@ -539,7 +544,7 @@ getThunkPtr thunkDir upstream = do
539544 remotes <- lines <$> readProcess "hub" [ "-C", thunkDir, "remote" ] ""
540545 --Check that the upstream specified actually exists
541546 case L.find (== upstream) remotes of
542− Nothing -> fail $ "thunk pack: upstream " <> upstream <> " does not exist"
547+ Nothing -> failWith $ T.pack $ "thunk pack: upstream " <> upstream <> " does not exist"
543548 Just _ -> return ()
544549 -- iterate over cartesian product
545550 forM_ repoHeads $ \hd -> do
@@ -553,7 +558,7 @@ getThunkPtr thunkDir upstream = do
553558 , "remotes/" <> rm <> "/" <> hd
554559 ] ""
555560 case remoteMergeRev == localRev of
556− False -> fail $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]
561+ False -> failWith $ T.pack $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]
557562 True -> return ()
558563
559564 --We assume it's safe to pack the thunk at this point
@@ -566,7 +571,7 @@ getThunkPtr thunkDir upstream = do
566571 mRemoteUri = parseURIReference remoteUri'
567572 <|> parseSshShorthand remoteUri'
568573 thunkPtr <- case mRemoteUri of
569− Nothing -> fail uriParseFailure
574+ Nothing -> failWith $ T.pack uriParseFailure
570575 Just remoteUri -> do
571576 refs <- fmap (refsToTuples . words) . lines <$> readProcess "hub"
572577 [ "-C"
@@ -626,7 +631,7 @@ getThunkPtr thunkDir upstream = do
626631 case uriScheme u of
627632 "https:" -> return ()
628633 "git:" -> return ()
629− _ -> fail $ "thunk pack: obelisk currently only supports https and git protocols for non-GitHub remotes"
634+ _ -> failWith "thunk pack: obelisk currently only supports https and git protocols for non-GitHub remotes"
630635 $notImplemented
631636 parseSshShorthand uri' = do
632637 -- This is what git does to check that the remote
skeleton/common/src/Common/Api.hs+2−2
@@ -1,4 +1,4 @@
1−module Common.Api where
1+module Common.Api where
22
33commonStuff :: String
4−commonStuff = "here is a comon string"
4+commonStuff = "here is a common string"