{-# 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