Initial commit
This commit is contained in:
328
lib/GHup.hs
Normal file
328
lib/GHup.hs
Normal file
@@ -0,0 +1,328 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module GHup
|
||||
(
|
||||
-- * Types
|
||||
ForkResult(..)
|
||||
, CloneMethod(..)
|
||||
, ProcessError(..)
|
||||
-- * Settings
|
||||
, getSettings
|
||||
, writeSettings
|
||||
-- * Github / Git actions
|
||||
, prepareRepoForPR'
|
||||
, prepareRepoForPR
|
||||
, forkRepository
|
||||
, cloneRepository
|
||||
, setUpstream
|
||||
, createBranch
|
||||
, deleteFork'
|
||||
, deleteFork
|
||||
-- * Parsers
|
||||
, parseURL
|
||||
, ghURLParser
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad.Except
|
||||
import Data.Attoparsec.ByteString
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified Data.ByteString.Lazy.UTF8 as LUTF8
|
||||
import Data.Functor ( (<&>) )
|
||||
import Data.Proxy
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Data.Word8
|
||||
import GitHub.Auth
|
||||
import GitHub.Data.Name
|
||||
import GitHub.Data.URL
|
||||
import GitHub.Endpoints.Repos
|
||||
import GitHub.Request
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Prelude hiding ( readFile
|
||||
, writeFile
|
||||
)
|
||||
import System.Posix.ByteString ( getEnv
|
||||
, RawFilePath
|
||||
)
|
||||
import System.Posix.Files.ByteString
|
||||
import qualified System.Posix.Process.ByteString
|
||||
as SPPB
|
||||
import System.Posix.Process.ByteString
|
||||
( ProcessStatus )
|
||||
import qualified System.Posix.User as PU
|
||||
import System.Exit
|
||||
import Text.Read ( readEither )
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Data types ]--
|
||||
------------------
|
||||
|
||||
|
||||
data ForkResult = ForkResult {
|
||||
upstream :: Repo
|
||||
, downstream :: Repo
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data CloneMethod = CloneSSH
|
||||
| CloneHTTP
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ProcessError = NoSuchPid
|
||||
| ProcessFailed Int
|
||||
| ProcessInterrupted
|
||||
deriving (Eq, Show)
|
||||
|
||||
data UrlParseResult = UrlParseResult {
|
||||
owner :: Name Owner
|
||||
, repo :: Name Repo
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
data Settings = Settings {
|
||||
auth :: Auth
|
||||
} deriving (Eq, Read, Show)
|
||||
|
||||
|
||||
deriving instance Read Auth
|
||||
|
||||
|
||||
|
||||
|
||||
----------------
|
||||
--[ Settings ]--
|
||||
----------------
|
||||
|
||||
|
||||
|
||||
writeSettings :: Auth -> IO ()
|
||||
writeSettings auth = 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))
|
||||
|
||||
|
||||
getSettingsFile :: IO (Path Abs)
|
||||
getSettingsFile = do
|
||||
let app_dir = [rel|ghup|] :: Path Rel
|
||||
getEnv (u8 "XDG_CONFIG_HOME") >>= \case
|
||||
Just config -> do
|
||||
pc <- parseAbs config
|
||||
pure $ pc </> app_dir
|
||||
Nothing -> do
|
||||
let config_dir = [rel|.config|] :: Path Rel
|
||||
home <- getHomeDirectory >>= parseAbs
|
||||
pure $ home </> config_dir </> app_dir
|
||||
|
||||
|
||||
getSettings :: IO (Either String Settings)
|
||||
getSettings = runExceptT (fromEnv <|> fromFile)
|
||||
|
||||
where
|
||||
fromEnv :: ExceptT String IO Settings
|
||||
fromEnv = do
|
||||
(lift $ getEnv (u8 "GITHUB_TOKEN")) >>= \case
|
||||
Just t -> pure $ Settings (OAuth t)
|
||||
Nothing -> throwError "Not found"
|
||||
fromFile :: ExceptT String IO Settings
|
||||
fromFile = do
|
||||
sf <- lift $ getSettingsFile
|
||||
out <-
|
||||
ExceptT
|
||||
$ ( flip catchIOError (\e -> pure $ Left $ show e)
|
||||
$ fmap Right
|
||||
$ readFile sf
|
||||
)
|
||||
liftEither $ readEither (LUTF8.toString out)
|
||||
|
||||
|
||||
|
||||
|
||||
----------------------------
|
||||
--[ Github / Git actions ]--
|
||||
----------------------------
|
||||
|
||||
|
||||
-- | Same as 'prepareRepoForPR', but gets the auth from the config file
|
||||
-- and parses the owner/repo from the given repo url string.
|
||||
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
|
||||
UrlParseResult {..} <- liftEither $ parseURL repoString
|
||||
Settings {..} <- ExceptT getSettings
|
||||
ExceptT $ prepareRepoForPR auth owner repo repobase branch
|
||||
|
||||
|
||||
|
||||
-- | Fork the repository to my account, clone it, add original upstream
|
||||
-- as remote, optionally switch to the given branch.
|
||||
prepareRepoForPR :: AuthMethod am
|
||||
=> am
|
||||
-> Name Owner
|
||||
-> Name Repo
|
||||
-> Maybe (Path b) -- ^ base path where the repo should be cloned
|
||||
-> Maybe ByteString -- ^ PR branch name to switch to
|
||||
-> IO (Either String ())
|
||||
prepareRepoForPR am owner repo repobase branch = runExceptT $ do
|
||||
repodest <- case repobase of
|
||||
Just rb ->
|
||||
((rb </>) <$> (parseRel $ E.encodeUtf8 $ untagName repo)) >>= lift . toAbs
|
||||
Nothing -> (parseRel $ E.encodeUtf8 $ untagName repo) >>= lift . toAbs
|
||||
ForkResult {..} <- withExceptT show $ ExceptT $ forkRepository am owner repo
|
||||
withExceptT show $ ExceptT $ cloneRepository CloneSSH downstream repodest
|
||||
withExceptT show $ ExceptT $ setUpstream upstream repodest
|
||||
case branch of
|
||||
Just b -> withExceptT show $ ExceptT $ createBranch b repodest
|
||||
Nothing -> pure ()
|
||||
|
||||
|
||||
forkRepository :: AuthMethod am
|
||||
=> am
|
||||
-> Name Owner
|
||||
-> Name Repo
|
||||
-> IO (Either Error ForkResult)
|
||||
forkRepository am owner repo = runExceptT $ do
|
||||
upstream <- ExceptT $ github' (repositoryR owner repo)
|
||||
downstream <- ExceptT $ github am (forkExistingRepoR owner repo Nothing)
|
||||
pure $ ForkResult { .. }
|
||||
|
||||
|
||||
cloneRepository :: CloneMethod
|
||||
-> Repo
|
||||
-> Path b -- ^ full path where the repo should be cloned to
|
||||
-> IO (Either ProcessError ())
|
||||
cloneRepository CloneSSH (Repo { repoSshUrl = (Just url) }) dest =
|
||||
_clone (E.encodeUtf8 $ getUrl url) (toFilePath dest)
|
||||
cloneRepository CloneHTTP (Repo { repoCloneUrl = (Just url) }) dest =
|
||||
_clone (E.encodeUtf8 $ getUrl url) (toFilePath dest)
|
||||
cloneRepository _ _ _ = fail "No clone url!"
|
||||
|
||||
|
||||
|
||||
setUpstream :: Repo -- ^ upstream
|
||||
-> Path b -- ^ full path to repo
|
||||
-> IO (Either ProcessError ())
|
||||
setUpstream (Repo { repoCloneUrl = (Just url) }) repodir = _runGit
|
||||
[ u8 "-C"
|
||||
, toFilePath repodir
|
||||
, u8 "remote"
|
||||
, u8 "add"
|
||||
, u8 "upstream"
|
||||
, (E.encodeUtf8 $ getUrl url)
|
||||
]
|
||||
setUpstream _ _ = fail "No clone url!"
|
||||
|
||||
|
||||
createBranch :: ByteString -- ^ branch name
|
||||
-> Path b -- ^ full path to repo
|
||||
-> IO (Either ProcessError ())
|
||||
createBranch branch repodir =
|
||||
_runGit [u8 "-C", toFilePath repodir, u8 "checkout", u8 "-b", branch]
|
||||
|
||||
|
||||
-- | 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' repoString = runExceptT $ do
|
||||
UrlParseResult {..} <- liftEither $ parseURL repoString
|
||||
Settings {..} <- ExceptT getSettings
|
||||
ExceptT $ deleteFork auth owner repo
|
||||
|
||||
|
||||
deleteFork :: AuthMethod am
|
||||
=> am
|
||||
-> Name Owner
|
||||
-> Name Repo
|
||||
-> IO (Either String ())
|
||||
deleteFork am owner repo = runExceptT $ do
|
||||
(withExceptT show $ ExceptT $ github' (repositoryR owner repo)) >>= \case
|
||||
(Repo { repoFork = Just True }) -> pure ()
|
||||
_ -> fail "Not a fork"
|
||||
withExceptT show $ ExceptT $ github am (deleteRepoR owner repo)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Parsers ]--
|
||||
---------------
|
||||
|
||||
|
||||
parseURL :: ByteString -> Either String UrlParseResult
|
||||
parseURL = parseOnly ghURLParser
|
||||
|
||||
|
||||
ghURLParser :: Parser UrlParseResult
|
||||
ghURLParser =
|
||||
(\n r ->
|
||||
let owner = mkName (Proxy :: Proxy Owner) (E.decodeUtf8 n)
|
||||
repo = mkName (Proxy :: Proxy Repo) (E.decodeUtf8 r)
|
||||
in UrlParseResult { .. }
|
||||
)
|
||||
<$> ( ( str "https://github.com/"
|
||||
<|> str "http://github.com/"
|
||||
<|> str "git@github.com:"
|
||||
<|> empty'
|
||||
)
|
||||
*> takeWhile1 (\w -> (w /= _slash) && isAlphaNum w)
|
||||
<* word8 _slash
|
||||
)
|
||||
<*> (takeWhile1 isAlphaNum <* ((str ".git" <|> empty') <* endOfInput))
|
||||
where
|
||||
str = string . u8
|
||||
empty' = str ""
|
||||
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ Helpers ]--
|
||||
---------------
|
||||
|
||||
|
||||
u8 :: String -> ByteString
|
||||
u8 = UTF8.fromString
|
||||
|
||||
_clone :: ByteString -> ByteString -> IO (Either ProcessError ())
|
||||
_clone url dest = _runGit [u8 "clone", url, dest]
|
||||
|
||||
_toGitError :: Maybe ProcessStatus -> Either ProcessError ()
|
||||
_toGitError ps = case ps of
|
||||
Just (SPPB.Exited ExitSuccess ) -> Right ()
|
||||
Just (SPPB.Exited (ExitFailure i)) -> Left $ ProcessFailed i
|
||||
Just (SPPB.Terminated _ _ ) -> Left $ ProcessInterrupted
|
||||
Just (SPPB.Stopped _ ) -> Left $ ProcessInterrupted
|
||||
Nothing -> Left $ NoSuchPid
|
||||
|
||||
_runGit :: [ByteString] -> IO (Either ProcessError ())
|
||||
_runGit args = do
|
||||
pid <- executeFile ([rel|git|] :: Path Rel) args
|
||||
SPPB.getProcessStatus True True pid <&> _toGitError
|
||||
|
||||
|
||||
getHomeDirectory :: IO RawFilePath
|
||||
getHomeDirectory = do
|
||||
e <- getEnv (u8 "HOME")
|
||||
case e of
|
||||
Just fp -> pure fp
|
||||
Nothing -> do
|
||||
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
|
||||
pure $ u8 h -- this is a guess
|
||||
Reference in New Issue
Block a user