hasufell
/
ghup
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Cleanup and prettify

This commit is contained in:
Julian Ospald 2020-01-30 23:12:46 +01:00
parent 5f9159aaf4
commit 89e3d420e5
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
3 changed files with 73 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
app/Main.hs
View File

@ -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)

6
ghup.cabal
View File

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

57
lib/GHup.hs
View File

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