diff --git a/app/Main.hs b/app/Main.hs index 131896c..821ffca 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -8,6 +8,7 @@ import GHup import GitHub.Auth import HPath import Options.Applicative +import System.Console.Pretty import System.Exit @@ -29,7 +30,8 @@ data ForkOptions = ForkOptions } data ConfigOptions = ConfigOptions { - oAuth :: ByteString + oAuth :: ByteString + , bPath :: Maybe ByteString } @@ -45,8 +47,18 @@ opts = subparser ) configOpts :: Parser ConfigOptions -configOpts = ConfigOptions <$> strOption - (short 'o' <> long "oauth" <> metavar "OAUTH" <> help "The OAUTH token") +configOpts = + ConfigOptions + <$> strOption + (short 'o' <> long "oauth" <> metavar "OAUTH" <> help + "The OAUTH token" + ) + <*> optional + (strOption + ((short 'p') <> long "base-path" <> metavar "BASE_PATH" <> help + "The base path to clone into" + ) + ) forkOpts :: Parser ForkOptions forkOpts = @@ -82,8 +94,10 @@ main = do Just p -> prepareRepoForPR' repo (Just p) newBranch Nothing -> fail "Repo path must be absolute" Nothing -> prepareRepoForPR' repo Nothing newBranch - Config (ConfigOptions {..}) -> writeSettings (OAuth oAuth) <&> Right - Del (DelOptions {..} ) -> deleteFork' del + Config (ConfigOptions {..}) -> do + p <- maybe (pure Nothing) (fmap Just . parseAbs) bPath + writeSettings (Settings (OAuth oAuth) p) <&> Right + Del (DelOptions {..}) -> deleteFork' del case e of - Right () -> putStrLn "success!" - Left t -> die t + Right () -> _info "success!" + Left t -> die (color Red $ t) diff --git a/ghup.cabal b/ghup.cabal index adf10f7..61098be 100644 --- a/ghup.cabal +++ b/ghup.cabal @@ -26,6 +26,7 @@ library , hpath-io ^>= 0.13.1 , http-client ^>= 0.6.4 , mtl ^>= 2.2 + , pretty-terminal ^>= 0.1 , safe-exceptions ^>= 0.1 , streamly ^>= 0.7 , text ^>= 1.2 @@ -35,7 +36,7 @@ library hs-source-dirs: lib ghc-options: -Wall default-language: Haskell2010 - default-extensions: LambdaCase, MultiWayIf, RecordWildCards + default-extensions: LambdaCase, MultiWayIf, RecordWildCards, TupleSections executable ghup main-is: Main.hs @@ -47,9 +48,10 @@ executable ghup , github ^>= 0.24 , hpath ^>= 0.11 , optparse-applicative ^>= 0.15 + , pretty-terminal ^>= 0.1 hs-source-dirs: app default-language: Haskell2010 - default-extensions: LambdaCase, MultiWayIf, RecordWildCards + default-extensions: LambdaCase, MultiWayIf, RecordWildCards, TupleSections source-repository head type: git diff --git a/lib/GHup.hs b/lib/GHup.hs index 32834d6..2ef3a7b 100644 --- a/lib/GHup.hs +++ b/lib/GHup.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -9,6 +10,7 @@ module GHup ForkResult(..) , CloneMethod(..) , ProcessError(..) + , Settings(..) -- * Settings , getSettings , writeSettings @@ -24,6 +26,10 @@ module GHup -- * Parsers , parseURL , ghURLParser + -- * Utils + , _info + , _warn + , _err ) where @@ -48,6 +54,10 @@ import HPath.IO import Prelude hiding ( readFile , writeFile ) +import System.Console.Pretty +import System.IO ( hPutStrLn + , stderr + ) import System.Posix.ByteString ( getEnv , RawFilePath ) @@ -88,12 +98,23 @@ data UrlParseResult = UrlParseResult { data Settings = Settings { - auth :: Auth + auth :: Auth + , basePath :: Maybe (Path Abs) } deriving (Eq, Read, Show) deriving instance Read Auth +instance Read (Path Abs) where + readsPrec p input = + let str = readsPrec p input :: [(String, String)] + in case str of + [(s, n)] -> case parseAbs (UTF8.fromString s) of + Just p' -> [(p', n)] + Nothing -> [] + _ -> [] + + @@ -103,17 +124,16 @@ deriving instance Read Auth -writeSettings :: Auth -> IO () -writeSettings auth = do +writeSettings :: Settings -> IO () +writeSettings settings = do sf <- getSettingsFile - let settings = Settings auth let fileperms = ownerWriteMode `unionFileModes` ownerReadMode `unionFileModes` groupWriteMode `unionFileModes` groupReadMode writeFile sf (Just fileperms) (u8 . show $ settings) - putStrLn ("Written config to file " <> (UTF8.toString $ toFilePath sf)) + _info ("Written config to file " <> (UTF8.toString $ toFilePath sf)) getSettingsFile :: IO (Path Abs) @@ -136,7 +156,7 @@ getSettings = runExceptT (fromEnv <|> fromFile) fromEnv :: ExceptT String IO Settings fromEnv = do (lift $ getEnv (u8 "GITHUB_TOKEN")) >>= \case - Just t -> pure $ Settings (OAuth t) + Just t -> pure $ Settings (OAuth t) Nothing Nothing -> throwError "Not found" fromFile :: ExceptT String IO Settings fromFile = do @@ -163,9 +183,12 @@ prepareRepoForPR' :: ByteString -- ^ string that contains repo url -> Maybe (Path b) -- ^ base path where the repo should be cloned -> Maybe ByteString -- ^ PR branch name to switch to -> IO (Either String ()) -prepareRepoForPR' repoString repobase branch = runExceptT $ do +prepareRepoForPR' repoString mRepobase branch = runExceptT $ do UrlParseResult {..} <- liftEither $ parseURL repoString Settings {..} <- ExceptT getSettings + repobase <- case mRepobase of + Just r -> fmap Just $ lift $ toAbs r + Nothing -> pure basePath ExceptT $ prepareRepoForPR auth owner repo repobase branch @@ -190,6 +213,10 @@ prepareRepoForPR am owner repo repobase branch = runExceptT $ do case branch of Just b -> withExceptT show $ ExceptT $ createBranch b repodest Nothing -> pure () + lift $ _info + ( "To change to the repo dir, run:\n\tcd " + <> (UTF8.toString $ toFilePath repodest) + ) forkRepository :: AuthMethod am @@ -238,8 +265,7 @@ createBranch branch repodir = -- | Same as deleteFork, but gets the auth from the config file -- and parses the owner/repo from the given repo url string. -deleteFork' :: ByteString - -> IO (Either String ()) +deleteFork' :: ByteString -> IO (Either String ()) deleteFork' repoString = runExceptT $ do UrlParseResult {..} <- liftEither $ parseURL repoString Settings {..} <- ExceptT getSettings @@ -326,3 +352,16 @@ getHomeDirectory = do Nothing -> do h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID) pure $ u8 h -- this is a guess + + +_info :: String -> IO () +_info = putStrLn . color Green + +_warn :: String -> IO () +_warn = _stderr . color Yellow + +_err :: String -> IO () +_err = _stderr . color Red + +_stderr :: String -> IO () +_stderr = hPutStrLn stderr