3d0188e · obelisk · git.iko.soy

git.iko.soy/obelisk

Use MonadIO for logging functions

commit3d0188ea328ddf919a2c3cc0512d713a0594be66 authorSridhar Ratnakumar <srid@srid.ca> dateThu 10 May 2018, 17:43 (8 years ago) parentf186c6d

4 files changed+29−29

compare with master

unifiedsplit

lib/command/src/Obelisk/Command.hs+1−1 lib/command/src/Obelisk/Command/CLI.hs+15−15 lib/command/src/Obelisk/Command/Project.hs+4−4 lib/command/src/Obelisk/Command/Thunk.hs+9−9

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

@@ -202,7 +202,7 @@ ob = \case

202202 ObCommand_Deploy dc -> case dc of

203203 DeployCommand_Init deployOpts -> withProjectRoot "." $ \root -> do

204204 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

206206 Right (ThunkData_Packed ptr) -> return ptr

207207 Right (ThunkData_Checkout (Just ptr)) -> return ptr

208208 Right (ThunkData_Checkout Nothing) ->

lib/command/src/Obelisk/Command/CLI.hs+15−15

@@ -3,8 +3,8 @@

33{-# LANGUAGE MultiParamTypeClasses #-}

44module Obelisk.Command.CLI where

6−import Control.Monad.Catch (MonadMask, finally)

7−import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, ask, liftIO, runReaderT)

6+import Control.Monad.Catch (finally)

7+import Control.Monad.Reader (MonadIO, liftIO)

88import Data.List (isInfixOf)

99import Data.Text (Text)

1010import qualified Data.Text as T

@@ -16,14 +16,14 @@ import System.IO (hFlush, hIsTerminalDevice)

1616import System.Console.ANSI

1717import System.Console.Questioner (dots1Spinner, stopIndicator)

1818

19−import Obelisk.App (Obelisk)

19+import Obelisk.App (MonadObelisk)

2020

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

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

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

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

2525withSpinner

26− :: (MonadReader Obelisk m, MonadIO m, MonadMask m)

26+ :: MonadObelisk m

2727 => String -- ^ Text to print alongside the spinner

2828 -> Maybe String -- ^ Optional text to print at the end

2929 -> m a -- ^ Action to run and wait for

@@ -39,7 +39,7 @@ withSpinner s e f = do

3939 result <- finally f $ do

4040 liftIO $ stopIndicator spinner

4141 case e of

42− Just exitMsg -> liftIO $ putInfo $ T.pack exitMsg

42+ Just exitMsg -> putInfo $ T.pack exitMsg

4343 Nothing -> liftIO $ hFlush stdout

4444 return result

4545

@@ -47,20 +47,20 @@ data Level = Level_Normal | Level_Warning | Level_Error

4747 deriving (Bounded, Enum, Eq, Ord, Show)

4848

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

50−failWith :: Text -> IO a

51−failWith = ioError . userError . T.unpack

50+failWith :: MonadIO m => Text -> m a

51+failWith = liftIO . ioError . userError . T.unpack

5252

53−putError :: Text -> IO ()

54−putError = putMsg Level_Error

53+putError :: MonadIO m => Text -> m ()

54+putError = liftIO . putMsg Level_Error

5555

56−putWarning :: Text -> IO ()

57−putWarning = putMsg Level_Warning

56+putWarning :: MonadIO m => Text -> m ()

57+putWarning = liftIO . putMsg Level_Warning

5858

59−putInfo :: Text -> IO ()

60−putInfo = putMsg Level_Normal

59+putInfo :: MonadIO m => Text -> m ()

60+putInfo = liftIO . putMsg Level_Normal

6161

62−putMsg :: Level -> Text -> IO ()

63−putMsg level s = do

62+putMsg :: MonadIO m => Level -> Text -> m ()

63+putMsg level s = liftIO $ do

6464 setColor level

6565 T.putStrLn s

6666 setSGR [Reset]

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

@@ -88,7 +88,7 @@ initProject source = do

8888-- | Find the Obelisk implementation for the project at the given path

8989findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)

9090findProjectObeliskCommand target = do

91− myUid <- liftIO $ getRealUserID

91+ myUid <- liftIO getRealUserID

9292 targetStat <- liftIO $ getFileStatus target

9393 (result, insecurePaths) <- liftIO $ flip runStateT [] $ do

9494 walkToProjectRoot target targetStat myUid >>= \case

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

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

103103 (Nothing, _) -> return Nothing

104104 (Just projDir, _) -> do

105− liftIO $ putError $ T.unlines

105+ putError $ 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."

@@ -112,14 +112,14 @@ findProjectObeliskCommand target = do

112112-- | Get the FilePath to the containing project directory, if there is one

113113findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)

114114findProjectRoot target = do

115− myUid <- liftIO $ getRealUserID

115+ myUid <- liftIO getRealUserID

116116 targetStat <- liftIO $ getFileStatus target

117117 (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat myUid) []

118118 return result

119119

120120withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m ()) -> m ()

121121withProjectRoot 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"

123123 Just root -> f root

124124

125125-- | 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

328328updateThunkToLatest :: MonadObelisk m => FilePath -> m ()

329329updateThunkToLatest target = do

330330 (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

332332 Right c -> case c of

333333 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"

335335 let src = _thunkPtr_source ptr

336336 rev <- liftIO $ getLatestRev src

337337 overwriteThunk overwrite $ ThunkPtr

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

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

411411 let cacheErrHandler e

412412 | 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

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

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

416416 liftIO $ createDirectoryIfMissing False cacheDir

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

423423 case cacheHit of

424424 Just c -> return c

425425 Nothing -> do

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

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

427427 _ <- nixBuild $ def

428428 { _nixBuildConfig_target = Target

429429 { _target_path = thunkDir

@@ -459,15 +459,15 @@ unpackThunk

459459 => FilePath

460460 -> m ()

461461unpackThunk 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)

463463 --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"

465465 Right (ThunkData_Packed tptr) -> case _thunkPtr_source tptr of

466466 ThunkSource_GitHub s | (thunkParent, thunkName) <- splitFileName thunkDir -> withTempDirectory thunkParent thunkName $ \tmpRepo -> do

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

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

469469 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"

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

472472 withSpinner "Cloning from GitHub ..." (Just $ "Cloned " <> githubURI) $ do

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

@@ -514,8 +514,8 @@ packThunk

514514 -> String

515515 -> m ()

516516packThunk thunkDir upstream = readThunk thunkDir >>= \case

517− Left err -> liftIO $ failWith $ T.pack $ "thunk pack: " <> show err

518− Right (ThunkData_Packed _) -> liftIO $ failWith "pack: thunk is already packed"

517+ Left err -> failWith $ T.pack $ "thunk pack: " <> show err

518+ Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"

519519 Right (ThunkData_Checkout _) -> do

520520 thunkPtr <- liftIO $ getThunkPtr thunkDir upstream

521521 liftIO $ callProcess "rm"