git.iko.soy/obelisk
on master help sign in
Use MonadIO for logging functions
3d0188eSridhar Ratnakumar
lib/command/src/Obelisk/Command.hs+1−1
compare with master
unifiedsplit
@@ -202,7 +202,7 @@ ob = \case
202 ObCommand_Deploy dc -> case dc of
202 ObCommand_Deploy dc -> case dc of
203 DeployCommand_Init deployOpts -> withProjectRoot "." $ \root -> do
203 DeployCommand_Init deployOpts -> withProjectRoot "." $ \root -> do
204 thunkPtr <- readThunk root >>= \case
204 thunkPtr <- readThunk root >>= \case
205− Left err -> liftIO $ failWith $ T.pack $ "thunk pack: " <> show err
205+ Left err -> failWith $ T.pack $ "thunk pack: " <> show err
206 Right (ThunkData_Packed ptr) -> return ptr
206 Right (ThunkData_Packed ptr) -> return ptr
207 Right (ThunkData_Checkout (Just ptr)) -> return ptr
207 Right (ThunkData_Checkout (Just ptr)) -> return ptr
208 Right (ThunkData_Checkout Nothing) ->
208 Right (ThunkData_Checkout Nothing) ->
lib/command/src/Obelisk/Command/CLI.hs+15−15
@@ -3,8 +3,8 @@
3{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4module Obelisk.Command.CLI where
4module Obelisk.Command.CLI where
5
5
6−import Control.Monad.Catch (MonadMask, finally)
6+import Control.Monad.Catch (finally)
7−import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, ask, liftIO, runReaderT)
7+import Control.Monad.Reader (MonadIO, liftIO)
8import Data.List (isInfixOf)
8import Data.List (isInfixOf)
9import Data.Text (Text)
9import Data.Text (Text)
10import qualified Data.Text as T
10import qualified Data.Text as T
@@ -16,14 +16,14 @@ import System.IO (hFlush, hIsTerminalDevice)
16import System.Console.ANSI
16import System.Console.ANSI
17import System.Console.Questioner (dots1Spinner, stopIndicator)
17import System.Console.Questioner (dots1Spinner, stopIndicator)
18
18
19−import Obelisk.App (Obelisk)
19+import Obelisk.App (MonadObelisk)
20
20
21-- TODO: This doesn't handle the put* line of functions below, in that: when we print anything while the
21-- TODO: This doesn't handle the put* line of functions below, in that: when we print anything while the
22-- spinner is already running, it won't appear correctly in the terminal. The exception is `failWith` which
22-- spinner is already running, it won't appear correctly in the terminal. The exception is `failWith` which
23-- raises an exception (that gets handled properly here). One solution to fix this problem is to run a
23-- raises an exception (that gets handled properly here). One solution to fix this problem is to run a
24-- singleton spinner thread and interact with it in order to print something.
24-- singleton spinner thread and interact with it in order to print something.
25withSpinner
25withSpinner
26− :: (MonadReader Obelisk m, MonadIO m, MonadMask m)
26+ :: MonadObelisk m
27 => String -- ^ Text to print alongside the spinner
27 => String -- ^ Text to print alongside the spinner
28 -> Maybe String -- ^ Optional text to print at the end
28 -> Maybe String -- ^ Optional text to print at the end
29 -> m a -- ^ Action to run and wait for
29 -> m a -- ^ Action to run and wait for
@@ -39,7 +39,7 @@ withSpinner s e f = do
39 result <- finally f $ do
39 result <- finally f $ do
40 liftIO $ stopIndicator spinner
40 liftIO $ stopIndicator spinner
41 case e of
41 case e of
42− Just exitMsg -> liftIO $ putInfo $ T.pack exitMsg
42+ Just exitMsg -> putInfo $ T.pack exitMsg
43 Nothing -> liftIO $ hFlush stdout
43 Nothing -> liftIO $ hFlush stdout
44 return result
44 return result
45
45
@@ -47,20 +47,20 @@ data Level = Level_Normal | Level_Warning | Level_Error
47 deriving (Bounded, Enum, Eq, Ord, Show)
47 deriving (Bounded, Enum, Eq, Ord, Show)
48
48
49-- TODO: Handle this error cleanly when evaluating outside of `withSpinner` (eg: runCLI)
49-- TODO: Handle this error cleanly when evaluating outside of `withSpinner` (eg: runCLI)
50−failWith :: Text -> IO a
50+failWith :: MonadIO m => Text -> m a
51−failWith = ioError . userError . T.unpack
51+failWith = liftIO . ioError . userError . T.unpack
52
52
53−putError :: Text -> IO ()
53+putError :: MonadIO m => Text -> m ()
54−putError = putMsg Level_Error
54+putError = liftIO . putMsg Level_Error
55
55
56−putWarning :: Text -> IO ()
56+putWarning :: MonadIO m => Text -> m ()
57−putWarning = putMsg Level_Warning
57+putWarning = liftIO . putMsg Level_Warning
58
58
59−putInfo :: Text -> IO ()
59+putInfo :: MonadIO m => Text -> m ()
60−putInfo = putMsg Level_Normal
60+putInfo = liftIO . putMsg Level_Normal
61
61
62−putMsg :: Level -> Text -> IO ()
62+putMsg :: MonadIO m => Level -> Text -> m ()
63−putMsg level s = do
63+putMsg level s = liftIO $ do
64 setColor level
64 setColor level
65 T.putStrLn s
65 T.putStrLn s
66 setSGR [Reset]
66 setSGR [Reset]
lib/command/src/Obelisk/Command/Project.hs+4−4
@@ -88,7 +88,7 @@ initProject source = do
88-- | Find the Obelisk implementation for the project at the given path
88-- | Find the Obelisk implementation for the project at the given path
89findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)
89findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)
90findProjectObeliskCommand target = do
90findProjectObeliskCommand target = do
91− myUid <- liftIO $ getRealUserID
91+ myUid <- liftIO getRealUserID
92 targetStat <- liftIO $ getFileStatus target
92 targetStat <- liftIO $ getFileStatus target
93 (result, insecurePaths) <- liftIO $ flip runStateT [] $ do
93 (result, insecurePaths) <- liftIO $ flip runStateT [] $ do
94 walkToProjectRoot target targetStat myUid >>= \case
94 walkToProjectRoot target targetStat myUid >>= \case
@@ -102,7 +102,7 @@ findProjectObeliskCommand target = do
102 return $ Just $ obeliskCommandPkg </> "bin" </> "ob"
102 return $ Just $ obeliskCommandPkg </> "bin" </> "ob"
103 (Nothing, _) -> return Nothing
103 (Nothing, _) -> return Nothing
104 (Just projDir, _) -> do
104 (Just projDir, _) -> do
105− liftIO $ putError $ T.unlines
105+ putError $ T.unlines
106 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"
106 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"
107 , T.unlines $ fmap (T.pack . normalise) insecurePaths
107 , T.unlines $ fmap (T.pack . normalise) insecurePaths
108 , "Please ensure that all of these directories are owned by you and are not writable by anyone else."
108 , "Please ensure that all of these directories are owned by you and are not writable by anyone else."
@@ -112,14 +112,14 @@ findProjectObeliskCommand target = do
112-- | Get the FilePath to the containing project directory, if there is one
112-- | Get the FilePath to the containing project directory, if there is one
113findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)
113findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)
114findProjectRoot target = do
114findProjectRoot target = do
115− myUid <- liftIO $ getRealUserID
115+ myUid <- liftIO getRealUserID
116 targetStat <- liftIO $ getFileStatus target
116 targetStat <- liftIO $ getFileStatus target
117 (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat myUid) []
117 (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat myUid) []
118 return result
118 return result
119
119
120withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m ()) -> m ()
120withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m ()) -> m ()
121withProjectRoot target f = findProjectRoot target >>= \case
121withProjectRoot target f = findProjectRoot target >>= \case
122− Nothing -> liftIO $ failWith "Must be used inside of an Obelisk project"
122+ Nothing -> failWith "Must be used inside of an Obelisk project"
123 Just root -> f root
123 Just root -> f root
124
124
125-- | Walk from the current directory to the containing project's root directory,
125-- | Walk from the current directory to the containing project's root directory,
lib/command/src/Obelisk/Command/Thunk.hs+9−9
@@ -328,10 +328,10 @@ createThunkWithLatest target s = do
328updateThunkToLatest :: MonadObelisk m => FilePath -> m ()
328updateThunkToLatest :: MonadObelisk m => FilePath -> m ()
329updateThunkToLatest target = do
329updateThunkToLatest target = do
330 (overwrite, ptr) <- readThunk target >>= \case
330 (overwrite, ptr) <- readThunk target >>= \case
331− Left err -> liftIO $ failWith $ T.pack $ "thunk update: " <> show err
331+ Left err -> failWith $ T.pack $ "thunk update: " <> show err
332 Right c -> case c of
332 Right c -> case c of
333 ThunkData_Packed t -> return (target, t)
333 ThunkData_Packed t -> return (target, t)
334− ThunkData_Checkout _ -> liftIO $ failWith "cannot update an unpacked thunk"
334+ ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
335 let src = _thunkPtr_source ptr
335 let src = _thunkPtr_source ptr
336 rev <- liftIO $ getLatestRev src
336 rev <- liftIO $ getLatestRev src
337 overwriteThunk overwrite $ ThunkPtr
337 overwriteThunk overwrite $ ThunkPtr
@@ -410,7 +410,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do
410 --This should be guaranteed by the command argument parser.
410 --This should be guaranteed by the command argument parser.
411 let cacheErrHandler e
411 let cacheErrHandler e
412 | isDoesNotExistError e = return Nothing -- expected from a cache miss
412 | isDoesNotExistError e = return Nothing -- expected from a cache miss
413− | otherwise = liftIO $ putError (T.pack $ displayException e) >> return Nothing
413+ | otherwise = putError (T.pack $ displayException e) >> return Nothing
414 cacheDir = thunkDir </> ".attr-cache"
414 cacheDir = thunkDir </> ".attr-cache"
415 cachePath = cacheDir </> attr <.> "out"
415 cachePath = cacheDir </> attr <.> "out"
416 liftIO $ createDirectoryIfMissing False cacheDir
416 liftIO $ createDirectoryIfMissing False cacheDir
@@ -423,7 +423,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do
423 case cacheHit of
423 case cacheHit of
424 Just c -> return c
424 Just c -> return c
425 Nothing -> do
425 Nothing -> do
426− liftIO $ putWarning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
426+ putWarning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
427 _ <- nixBuild $ def
427 _ <- nixBuild $ def
428 { _nixBuildConfig_target = Target
428 { _nixBuildConfig_target = Target
429 { _target_path = thunkDir
429 { _target_path = thunkDir
@@ -459,15 +459,15 @@ unpackThunk
459 => FilePath
459 => FilePath
460 -> m ()
460 -> m ()
461unpackThunk thunkDir = readThunk thunkDir >>= \case
461unpackThunk thunkDir = readThunk thunkDir >>= \case
462− Left err -> liftIO $ failWith $ "thunk unpack: " <> (T.pack $ show err)
462+ Left err -> failWith $ "thunk unpack: " <> (T.pack $ show err)
463 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
463 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
464− Right (ThunkData_Checkout _) -> liftIO $ failWith "thunk unpack: thunk is already unpacked"
464+ Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"
465 Right (ThunkData_Packed tptr) -> case _thunkPtr_source tptr of
465 Right (ThunkData_Packed tptr) -> case _thunkPtr_source tptr of
466 ThunkSource_GitHub s | (thunkParent, thunkName) <- splitFileName thunkDir -> withTempDirectory thunkParent thunkName $ \tmpRepo -> do
466 ThunkSource_GitHub s | (thunkParent, thunkName) <- splitFileName thunkDir -> withTempDirectory thunkParent thunkName $ \tmpRepo -> do
467 mauth <- liftIO $ getHubAuth "github.com"
467 mauth <- liftIO $ getHubAuth "github.com"
468 repoResult <- liftIO $ executeRequestMaybe mauth $ repositoryR (_gitHubSource_owner s) (_gitHubSource_repo s)
468 repoResult <- liftIO $ executeRequestMaybe mauth $ repositoryR (_gitHubSource_owner s) (_gitHubSource_repo s)
469 githubURI <- liftIO $ either throwIO (return . repoSshUrl) repoResult >>= \case
469 githubURI <- liftIO $ either throwIO (return . repoSshUrl) repoResult >>= \case
470− Nothing -> liftIO $ failWith "Cannot determine clone URI for thunk source"
470+ Nothing -> failWith "Cannot determine clone URI for thunk source"
471 Just c -> return $ T.unpack $ getUrl c
471 Just c -> return $ T.unpack $ getUrl c
472 withSpinner "Cloning from GitHub ..." (Just $ "Cloned " <> githubURI) $ do
472 withSpinner "Cloning from GitHub ..." (Just $ "Cloned " <> githubURI) $ do
473 liftIO $ callProcess "hub" --TODO: Depend on hub explicitly
473 liftIO $ callProcess "hub" --TODO: Depend on hub explicitly
@@ -514,8 +514,8 @@ packThunk
514 -> String
514 -> String
515 -> m ()
515 -> m ()
516packThunk thunkDir upstream = readThunk thunkDir >>= \case
516packThunk thunkDir upstream = readThunk thunkDir >>= \case
517− Left err -> liftIO $ failWith $ T.pack $ "thunk pack: " <> show err
517+ Left err -> failWith $ T.pack $ "thunk pack: " <> show err
518− Right (ThunkData_Packed _) -> liftIO $ failWith "pack: thunk is already packed"
518+ Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
519 Right (ThunkData_Checkout _) -> do
519 Right (ThunkData_Checkout _) -> do
520 thunkPtr <- liftIO $ getThunkPtr thunkDir upstream
520 thunkPtr <- liftIO $ getThunkPtr thunkDir upstream
521 liftIO $ callProcess "rm"
521 liftIO $ callProcess "rm"