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

Refactor

Browse Source
This commit is contained in:
Julian Ospald 2020-01-31 17:38:29 +01:00
parent 2359090203
commit 7c7cb4cc60
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
3 changed files with 147 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
app/Main.hs
View File

@ -1,7 +1,9 @@
module Main where module Main where
import Control.Error.Util
import Control.Monad import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Reader
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
import Data.Dates ( getCurrentDateTime import Data.Dates ( getCurrentDateTime
@ -20,6 +22,7 @@ import GitHub.Auth
import GitHub.Data.Definitions import GitHub.Data.Definitions
import GitHub.Data.Name import GitHub.Data.Name
import GitHub.Data.Repos import GitHub.Data.Repos
import GitHub.Data.URL
import HPath import HPath
import Options.Applicative import Options.Applicative
import Safe import Safe
@ -117,19 +120,30 @@ lForkOpts = ListForkOptions <$> optional
main :: IO () main :: IO ()
main = do main = do
let
run e = do
settings <-
exceptT
( const die
. color Red
$ "Could not get settings, make sure to run 'ghup config' first"
)
pure
$ getSettings
(flip runReaderT) settings . runExceptT . withExceptT show $ e
e <- execParser (info (opts <**> helper) idm) >>= \case e <- execParser (info (opts <**> helper) idm) >>= \case
Fork (ForkOptions {..}) -> do Fork (ForkOptions {..}) -> run $ do
case repoBasePath of case repoBasePath of
Just rbp -> case parseAbs rbp of Just rbp -> case parseAbs rbp of
Just p -> prepareRepoForPR' repo (Just p) newBranch Just p -> prepareRepoForPR' repo (Just p) newBranch
Nothing -> fail "Repo path must be absolute" Nothing -> liftIO $ die (color Red $ "Repo path must be absolute")
Nothing -> prepareRepoForPR' repo Nothing newBranch Nothing -> prepareRepoForPR' repo Nothing newBranch
Config (ConfigOptions {..}) -> do Config (ConfigOptions {..}) -> do
p <- maybe (pure Nothing) (fmap Just . parseAbs) bPath p <- maybe (pure Nothing) (fmap Just . parseAbs) bPath
writeSettings (Settings (OAuth oAuth) p) <&> Right writeSettings (Settings (OAuth oAuth) p) <&> Right
Del (DelOptions {..} ) -> deleteFork' del Del (DelOptions {..} ) -> run $ deleteFork' del
ListForks (ListForkOptions {..}) -> runExceptT $ do ListForks (ListForkOptions {..}) -> run $ do
mtime <- lift $ case lSince of mtime <- liftIO $ case lSince of
Just t -> do Just t -> do
dt <- getCurrentDateTime dt <- getCurrentDateTime
let mt = let mt =
@ -144,16 +158,11 @@ main = do
) )
Nothing -> pure Nothing Nothing -> pure Nothing
forks <- ExceptT $ getForks' mtime forks <- withExceptT show $ getForks mtime
let formatted = intercalate "\n" $ fmap let formatted = intercalate "\n"
(\Repo {..} -> $ fmap (\Repo {..} -> T.unpack . getUrl $ repoHtmlUrl) forks
T.unpack (untagName $ simpleOwnerLogin repoOwner) liftIO $ putStrLn $ formatted
<> "/"
<> T.unpack (untagName repoName)
)
forks
lift $ putStrLn $ formatted
pure () pure ()
case e of case e of
Right () -> _info "success!" Right () -> pure ()
Left t -> die (color Red $ t) Left t -> die (color Red $ t)

1
ghup.cabal
View File

@ -47,6 +47,7 @@ executable ghup
build-depends: base ^>= 4.12 build-depends: base ^>= 4.12
, bytestring ^>= 0.10 , bytestring ^>= 0.10
, dates ^>= 0.2 , dates ^>= 0.2
, errors ^>= 2.3
, ghup , ghup
, github ^>= 0.24 , github ^>= 0.24
, hpath ^>= 0.11 , hpath ^>= 0.11

205
lib/GHup.hs
View File

@ -1,7 +1,10 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
module GHup module GHup
@ -23,7 +26,6 @@ module GHup
, createBranch , createBranch
, deleteFork' , deleteFork'
, deleteFork , deleteFork
, getForks'
, getForks , getForks
-- * Parsers -- * Parsers
, parseURL , parseURL
@ -37,7 +39,9 @@ where
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad.Except import Control.Monad.Except hiding ( fail )
import Control.Monad.Fail
import Control.Monad.Reader hiding ( fail )
import Data.Attoparsec.ByteString import Data.Attoparsec.ByteString
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
@ -58,6 +62,7 @@ import HPath
import HPath.IO import HPath.IO
import Prelude hiding ( readFile import Prelude hiding ( readFile
, writeFile , writeFile
, fail
) )
import System.Console.Pretty import System.Console.Pretty
import System.IO ( hPutStrLn import System.IO ( hPutStrLn
@ -103,8 +108,8 @@ data UrlParseResult = UrlParseResult {
data Settings = Settings { data Settings = Settings {
auth :: Auth _auth :: Auth
, basePath :: Maybe (Path Abs) , _basePath :: Maybe (Path Abs)
} deriving (Eq, Read, Show) } deriving (Eq, Read, Show)
@ -129,7 +134,7 @@ instance Read (Path Abs) where
writeSettings :: Settings -> IO () writeSettings :: (MonadThrow m, MonadIO m) => Settings -> m ()
writeSettings settings = do writeSettings settings = do
sf <- getSettingsFile sf <- getSettingsFile
let fileperms = let fileperms =
@ -137,41 +142,41 @@ writeSettings settings = do
`unionFileModes` ownerReadMode `unionFileModes` ownerReadMode
`unionFileModes` groupWriteMode `unionFileModes` groupWriteMode
`unionFileModes` groupReadMode `unionFileModes` groupReadMode
writeFile sf (Just fileperms) (u8 . show $ settings) liftIO $ writeFile sf (Just fileperms) (u8 . show $ settings)
_info ("Written config to file " <> (UTF8.toString $ toFilePath sf)) _info ("Written config to file " <> (UTF8.toString $ toFilePath sf))
getSettingsFile :: IO (Path Abs) getSettingsFile :: (MonadThrow m, MonadIO m) => m (Path Abs)
getSettingsFile = do getSettingsFile = do
let app_dir = [rel|ghup|] :: Path Rel let app_dir = [rel|ghup|] :: Path Rel
getEnv (u8 "XDG_CONFIG_HOME") >>= \case (liftIO $ getEnv (u8 "XDG_CONFIG_HOME")) >>= \case
Just config -> do Just config -> do
pc <- parseAbs config pc <- parseAbs config
pure $ pc </> app_dir pure $ pc </> app_dir
Nothing -> do Nothing -> do
let config_dir = [rel|.config|] :: Path Rel let config_dir = [rel|.config|] :: Path Rel
home <- getHomeDirectory >>= parseAbs home <- liftIO (getHomeDirectory >>= parseAbs)
pure $ home </> config_dir </> app_dir pure $ home </> config_dir </> app_dir
getSettings :: IO (Either String Settings) getSettings :: (MonadThrow m, MonadIO m) => ExceptT String m Settings
getSettings = runExceptT (fromEnv <|> fromFile) getSettings = (fromEnv <|> fromFile)
where where
fromEnv :: ExceptT String IO Settings fromEnv :: MonadIO m => ExceptT String m Settings
fromEnv = do fromEnv = do
(lift $ getEnv (u8 "GITHUB_TOKEN")) >>= \case (liftIO $ getEnv (u8 "GITHUB_TOKEN")) >>= \case
Just t -> pure $ Settings (OAuth t) Nothing Just t -> pure $ Settings (OAuth t) Nothing
Nothing -> throwError "Not found" Nothing -> throwError "Not found"
fromFile :: ExceptT String IO Settings fromFile :: (MonadThrow m, MonadIO m) => ExceptT String m Settings
fromFile = do fromFile = do
sf <- lift $ getSettingsFile sf <- getSettingsFile
out <- out <-
ExceptT ExceptT
$ ( flip catchIOError (\e -> pure $ Left $ show e) $ liftIO
$ fmap Right $ (flip catchIOError (\e -> pure $ Left $ show e) $ fmap Right $ readFile
$ readFile sf sf
) )
liftEither $ readEither (LUTF8.toString out) liftEither $ readEither (LUTF8.toString out)
@ -184,35 +189,44 @@ getSettings = runExceptT (fromEnv <|> fromFile)
-- | Same as 'prepareRepoForPR', but gets the auth from the config file -- | Same as 'prepareRepoForPR', but gets the auth from the config file
-- and parses the owner/repo from the given repo url string. -- and parses the owner/repo from the given repo url string.
prepareRepoForPR' :: ByteString -- ^ string that contains repo url prepareRepoForPR' :: ( MonadIO m
, MonadReader Settings m
, MonadFail m
, MonadThrow m
)
=> ByteString -- ^ string that contains repo url
-> Maybe (Path b) -- ^ base path where the repo should be cloned -> Maybe (Path b) -- ^ base path where the repo should be cloned
-> Maybe ByteString -- ^ PR branch name to switch to -> Maybe ByteString -- ^ PR branch name to switch to
-> IO (Either String ()) -> ExceptT String m ()
prepareRepoForPR' repoString mRepobase branch = runExceptT $ do prepareRepoForPR' repoString mRepobase branch = do
UrlParseResult {..} <- liftEither $ parseURL repoString UrlParseResult {..} <- liftEither $ parseURL repoString
Settings {..} <- ExceptT getSettings
repobase <- case mRepobase of repobase <- case mRepobase of
Just r -> fmap Just $ lift $ toAbs r Just r -> fmap Just $ liftIO $ toAbs r
Nothing -> pure basePath Nothing -> basePath
ExceptT $ prepareRepoForPR auth owner repo repobase branch prepareRepoForPR owner repo repobase branch
-- | Fork the repository to my account, clone it, add original upstream -- | Fork the repository to my account, clone it, add original upstream
-- as remote, optionally switch to the given branch. -- as remote, optionally switch to the given branch.
prepareRepoForPR :: AuthMethod am prepareRepoForPR :: ( MonadIO m
=> am , MonadReader Settings m
-> Name Owner , MonadFail m
, MonadThrow m
)
=> Name Owner
-> Name Repo -> Name Repo
-> Maybe (Path b) -- ^ base path where the repo should be cloned -> Maybe (Path b) -- ^ base path where the repo should be cloned
-> Maybe ByteString -- ^ PR branch name to switch to -> Maybe ByteString -- ^ PR branch name to switch to
-> IO (Either String ()) -> ExceptT String m ()
prepareRepoForPR am owner repo repobase branch = runExceptT $ do prepareRepoForPR owner repo repobase branch = do
repodest <- case repobase of repodest <- case repobase of
Just rb -> Just rb ->
((rb </>) <$> (parseRel $ E.encodeUtf8 $ untagName repo)) >>= lift . toAbs ((rb </>) <$> (parseRel $ E.encodeUtf8 $ untagName repo))
Nothing -> (parseRel $ E.encodeUtf8 $ untagName repo) >>= lift . toAbs >>= liftIO
ForkResult {..} <- withExceptT show $ ExceptT $ forkRepository am owner repo . toAbs
Nothing -> (parseRel $ E.encodeUtf8 $ untagName repo) >>= liftIO . toAbs
ForkResult {..} <- withExceptT show $ forkRepository owner repo
withExceptT show $ ExceptT $ cloneRepository CloneSSH downstream repodest withExceptT show $ ExceptT $ cloneRepository CloneSSH downstream repodest
withExceptT show $ ExceptT $ setUpstream upstream repodest withExceptT show $ ExceptT $ setUpstream upstream repodest
case branch of case branch of
@ -224,21 +238,21 @@ prepareRepoForPR am owner repo repobase branch = runExceptT $ do
) )
forkRepository :: AuthMethod am forkRepository :: (MonadIO m, MonadReader Settings m)
=> am => Name Owner
-> Name Owner
-> Name Repo -> Name Repo
-> IO (Either Error ForkResult) -> ExceptT Error m ForkResult
forkRepository am owner repo = runExceptT $ do forkRepository owner repo = do
upstream <- ExceptT $ github' (repositoryR owner repo) upstream <- github_ (repositoryR owner repo)
downstream <- ExceptT $ github am (forkExistingRepoR owner repo Nothing) downstream <- githubAuth (forkExistingRepoR owner repo Nothing)
pure $ ForkResult { .. } pure $ ForkResult { .. }
cloneRepository :: CloneMethod cloneRepository :: (MonadIO m, MonadFail m)
=> CloneMethod
-> Repo -> Repo
-> Path b -- ^ full path where the repo should be cloned to -> Path b -- ^ full path where the repo should be cloned to
-> IO (Either ProcessError ()) -> m (Either ProcessError ())
cloneRepository CloneSSH (Repo { repoSshUrl = (Just url) }) dest = cloneRepository CloneSSH (Repo { repoSshUrl = (Just url) }) dest =
_clone (E.encodeUtf8 $ getUrl url) (toFilePath dest) _clone (E.encodeUtf8 $ getUrl url) (toFilePath dest)
cloneRepository CloneHTTP (Repo { repoCloneUrl = (Just url) }) dest = cloneRepository CloneHTTP (Repo { repoCloneUrl = (Just url) }) dest =
@ -247,9 +261,10 @@ cloneRepository _ _ _ = fail "No clone url!"
setUpstream :: Repo -- ^ upstream setUpstream :: (MonadIO m, MonadFail m)
=> Repo -- ^ upstream
-> Path b -- ^ full path to repo -> Path b -- ^ full path to repo
-> IO (Either ProcessError ()) -> m (Either ProcessError ())
setUpstream (Repo { repoCloneUrl = (Just url) }) repodir = _runGit setUpstream (Repo { repoCloneUrl = (Just url) }) repodir = _runGit
[ u8 "-C" [ u8 "-C"
, toFilePath repodir , toFilePath repodir
@ -261,50 +276,48 @@ setUpstream (Repo { repoCloneUrl = (Just url) }) repodir = _runGit
setUpstream _ _ = fail "No clone url!" setUpstream _ _ = fail "No clone url!"
createBranch :: ByteString -- ^ branch name createBranch :: MonadIO m
=> ByteString -- ^ branch name
-> Path b -- ^ full path to repo -> Path b -- ^ full path to repo
-> IO (Either ProcessError ()) -> m (Either ProcessError ())
createBranch branch repodir = createBranch branch repodir =
_runGit [u8 "-C", toFilePath repodir, u8 "checkout", u8 "-b", branch] _runGit [u8 "-C", toFilePath repodir, u8 "checkout", u8 "-b", branch]
-- | Same as deleteFork, but gets the auth from the config file -- | Same as deleteFork, but gets the auth from the config file
-- and parses the owner/repo from the given repo url string. -- and parses the owner/repo from the given repo url string.
deleteFork' :: ByteString -> IO (Either String ()) deleteFork' :: (MonadIO m, MonadReader Settings m)
deleteFork' repoString = runExceptT $ do => ByteString
-> ExceptT String m ()
deleteFork' repoString = do
UrlParseResult {..} <- liftEither $ parseURL repoString UrlParseResult {..} <- liftEither $ parseURL repoString
Settings {..} <- ExceptT getSettings deleteFork owner repo
ExceptT $ deleteFork auth owner repo
deleteFork :: AuthMethod am deleteFork :: (MonadIO m, MonadReader Settings m)
=> am => Name Owner
-> Name Owner
-> Name Repo -> Name Repo
-> IO (Either String ()) -> ExceptT String m ()
deleteFork am owner repo = runExceptT $ do deleteFork owner repo = do
(withExceptT show $ ExceptT $ github' (repositoryR owner repo)) >>= \case (withExceptT show $ github_ (repositoryR owner repo)) >>= \case
(Repo { repoFork = Just True }) -> pure () (Repo { repoFork = Just True }) -> pure ()
_ -> throwError "Not a fork" _ -> throwError "Not a fork"
withExceptT show $ ExceptT $ github am (deleteRepoR owner repo) withExceptT show $ githubAuth (deleteRepoR owner repo)
getForks' :: Maybe UTCTime -> IO (Either String [Repo])
getForks' mtime = runExceptT $ do
Settings {..} <- ExceptT getSettings
withExceptT show $ ExceptT $ getForks auth mtime
getForks :: (MonadIO m, MonadReader Settings m)
getForks :: AuthMethod am => am -> Maybe UTCTime -> IO (Either Error [Repo]) => Maybe UTCTime
getForks am mtime = runExceptT $ do -> ExceptT Error m [Repo]
repos <- getForks mtime = do
ExceptT $ github am (currentUserReposR RepoPublicityAll FetchAll) repos <- githubAuth (currentUserReposR RepoPublicityAll FetchAll)
pure $ filter pure $ filter
(\case (\case
Repo { repoFork = Just True, repoUpdatedAt = Just t } -> Repo { repoFork = Just True, repoUpdatedAt = Just t } ->
maybe True (t >=) mtime maybe True (t >=) mtime
_ -> False _ -> False
) (toList repos) )
(toList repos)
@ -348,7 +361,7 @@ ghURLParser =
u8 :: String -> ByteString u8 :: String -> ByteString
u8 = UTF8.fromString u8 = UTF8.fromString
_clone :: ByteString -> ByteString -> IO (Either ProcessError ()) _clone :: MonadIO m => ByteString -> ByteString -> m (Either ProcessError ())
_clone url dest = _runGit [u8 "clone", url, dest] _clone url dest = _runGit [u8 "clone", url, dest]
_toGitError :: Maybe ProcessStatus -> Either ProcessError () _toGitError :: Maybe ProcessStatus -> Either ProcessError ()
@ -359,8 +372,8 @@ _toGitError ps = case ps of
Just (SPPB.Stopped _ ) -> Left $ ProcessInterrupted Just (SPPB.Stopped _ ) -> Left $ ProcessInterrupted
Nothing -> Left $ NoSuchPid Nothing -> Left $ NoSuchPid
_runGit :: [ByteString] -> IO (Either ProcessError ()) _runGit :: MonadIO m => [ByteString] -> m (Either ProcessError ())
_runGit args = do _runGit args = liftIO $ do
pid <- executeFile ([rel|git|] :: Path Rel) args pid <- executeFile ([rel|git|] :: Path Rel) args
SPPB.getProcessStatus True True pid <&> _toGitError SPPB.getProcessStatus True True pid <&> _toGitError
@ -375,14 +388,40 @@ getHomeDirectory = do
pure $ u8 h -- this is a guess pure $ u8 h -- this is a guess
_info :: String -> IO () _info :: MonadIO m => String -> m ()
_info = _stderr . color Green _info = liftIO . _stderr . color Green
_warn :: String -> IO () _warn :: MonadIO m => String -> m ()
_warn = _stderr . color Yellow _warn = liftIO . _stderr . color Yellow
_err :: String -> IO () _err :: MonadIO m => String -> m ()
_err = _stderr . color Red _err = liftIO . _stderr . color Red
_stderr :: String -> IO () _stderr :: MonadIO m => String -> m ()
_stderr = hPutStrLn stderr _stderr = liftIO . hPutStrLn stderr
auth :: MonadReader Settings m => m Auth
auth = asks _auth
basePath :: MonadReader Settings m => m (Maybe (Path Abs))
basePath = asks _basePath
githubAuth :: ( MonadReader Settings m
, MonadIO m
, ParseResponse mt req
, res ~ Either Error req
)
=> (GenRequest mt rw req)
-> ExceptT Error m req
githubAuth req = do
a <- auth
ExceptT $ liftIO $ github a req
github_ :: (MonadIO m, ParseResponse mt req, res ~ Either Error req, ro ~ 'RO)
=> (GenRequest mt ro req)
-> ExceptT Error m req
github_ req = do
ExceptT $ liftIO $ github' req