ghup/lib/GHup.hs

538 lines
16 KiB
Haskell
Raw Permalink Normal View History

2020-02-02 14:42:03 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
2020-02-02 13:33:25 +00:00
{-# LANGUAGE ExistentialQuantification #-}
2020-02-02 14:42:03 +00:00
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
2020-01-30 18:40:08 +00:00
module GHup
(
-- * Types
2020-02-02 13:33:25 +00:00
AnyPath(..)
, ForkResult(..)
2020-01-30 18:40:08 +00:00
, CloneMethod(..)
, ProcessError(..)
2020-01-30 22:12:46 +00:00
, Settings(..)
2020-01-30 18:40:08 +00:00
-- * Settings
, getSettings
, writeSettings
-- * Github / Git actions
, prepareRepoForPR'
, prepareRepoForPR
, forkRepository
, cloneRepository
, setUpstream
, createBranch
, deleteFork'
, deleteFork
2020-01-31 14:54:41 +00:00
, getForks
2020-02-02 13:33:25 +00:00
, postGistStdin
, postGistFiles
, postGist
2020-02-02 14:34:20 +00:00
, listGists
2020-01-30 18:40:08 +00:00
-- * Parsers
, parseURL
, ghURLParser
2020-01-30 22:12:46 +00:00
-- * Utils
, _info
, _warn
, _err
2020-02-02 13:33:25 +00:00
, uError
2020-01-30 18:40:08 +00:00
)
where
import Control.Applicative
import Control.Exception.Safe
2020-01-31 16:38:29 +00:00
import Control.Monad.Except hiding ( fail )
import Control.Monad.Fail
import Control.Monad.Reader hiding ( fail )
2020-02-02 13:33:25 +00:00
import Data.Aeson
import Data.Aeson.TH
2020-01-30 18:40:08 +00:00
import Data.Attoparsec.ByteString
import Data.ByteString ( ByteString )
2020-01-31 23:26:40 +00:00
import qualified Data.ByteString as B
2020-02-02 13:33:25 +00:00
import qualified Data.ByteString.Lazy as L
2020-01-30 18:40:08 +00:00
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Lazy.UTF8 as LUTF8
import Data.Functor ( (<&>) )
2020-02-02 13:33:25 +00:00
import qualified Data.HashMap.Strict as H
import Data.HashMap.Strict ( HashMap )
2020-01-31 18:34:05 +00:00
import Data.List
2020-01-30 18:40:08 +00:00
import Data.Proxy
2020-01-31 16:46:06 +00:00
import qualified Data.Text as T
2020-01-30 18:40:08 +00:00
import qualified Data.Text.Encoding as E
2020-02-02 13:33:25 +00:00
import qualified Data.Text.IO as T
import Data.Traversable
2020-01-31 14:54:41 +00:00
import Data.Time.Clock
2020-02-02 14:34:20 +00:00
import Data.Time.Format.ISO8601
import qualified Data.Vector as V
2020-01-30 18:40:08 +00:00
import Data.Word8
2020-01-31 14:54:41 +00:00
import GHC.Exts ( toList )
2020-01-30 18:40:08 +00:00
import GitHub.Auth
2020-02-02 13:33:25 +00:00
import GitHub.Data.Gists
2020-01-30 18:40:08 +00:00
import GitHub.Data.Name
import GitHub.Data.URL
2020-01-31 14:54:41 +00:00
import GitHub.Data.Request
2020-01-30 18:40:08 +00:00
import GitHub.Endpoints.Repos
2020-02-01 15:23:02 +00:00
import GitHub.Endpoints.Search
import GitHub.Endpoints.Users
2020-01-30 18:40:08 +00:00
import GitHub.Request
import HPath
import HPath.IO
import Prelude hiding ( readFile
, writeFile
2020-01-31 16:38:29 +00:00
, fail
2020-01-30 18:40:08 +00:00
)
2020-01-30 22:12:46 +00:00
import System.Console.Pretty
import System.IO ( hPutStrLn
, stderr
)
2020-01-30 18:40:08 +00:00
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 {
2020-01-31 16:38:29 +00:00
_auth :: Auth
, _basePath :: Maybe (Path Abs)
2020-01-30 18:40:08 +00:00
} deriving (Eq, Read, Show)
deriving instance Read Auth
2020-01-30 22:12:46 +00:00
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 -> []
_ -> []
2020-02-02 13:33:25 +00:00
data AnyPath = forall a . AnyPath (Path a)
2020-01-30 18:40:08 +00:00
----------------
--[ Settings ]--
----------------
2020-01-31 16:38:29 +00:00
writeSettings :: (MonadThrow m, MonadIO m) => Settings -> m ()
2020-01-30 22:12:46 +00:00
writeSettings settings = do
2020-01-30 18:40:08 +00:00
sf <- getSettingsFile
let fileperms =
ownerWriteMode
`unionFileModes` ownerReadMode
`unionFileModes` groupWriteMode
`unionFileModes` groupReadMode
2020-01-31 16:38:29 +00:00
liftIO $ writeFile sf (Just fileperms) (u8 . show $ settings)
2020-01-30 22:12:46 +00:00
_info ("Written config to file " <> (UTF8.toString $ toFilePath sf))
2020-01-30 18:40:08 +00:00
2020-01-31 16:38:29 +00:00
getSettingsFile :: (MonadThrow m, MonadIO m) => m (Path Abs)
2020-01-30 18:40:08 +00:00
getSettingsFile = do
let app_dir = [rel|ghup|] :: Path Rel
2020-01-31 16:38:29 +00:00
(liftIO $ getEnv (u8 "XDG_CONFIG_HOME")) >>= \case
2020-01-30 18:40:08 +00:00
Just config -> do
pc <- parseAbs config
pure $ pc </> app_dir
Nothing -> do
let config_dir = [rel|.config|] :: Path Rel
2020-01-31 16:38:29 +00:00
home <- liftIO (getHomeDirectory >>= parseAbs)
2020-01-30 18:40:08 +00:00
pure $ home </> config_dir </> app_dir
2020-01-31 16:38:29 +00:00
getSettings :: (MonadThrow m, MonadIO m) => ExceptT String m Settings
getSettings = (fromEnv <|> fromFile)
2020-01-30 18:40:08 +00:00
where
2020-01-31 16:38:29 +00:00
fromEnv :: MonadIO m => ExceptT String m Settings
2020-01-30 18:40:08 +00:00
fromEnv = do
2020-01-31 16:38:29 +00:00
(liftIO $ getEnv (u8 "GITHUB_TOKEN")) >>= \case
2020-01-30 22:12:46 +00:00
Just t -> pure $ Settings (OAuth t) Nothing
2020-01-30 18:40:08 +00:00
Nothing -> throwError "Not found"
2020-01-31 16:38:29 +00:00
fromFile :: (MonadThrow m, MonadIO m) => ExceptT String m Settings
2020-01-30 18:40:08 +00:00
fromFile = do
2020-01-31 16:38:29 +00:00
sf <- getSettingsFile
2020-01-30 18:40:08 +00:00
out <-
ExceptT
2020-01-31 16:38:29 +00:00
$ liftIO
$ (flip catchIOError (\e -> pure $ Left $ show e) $ fmap Right $ readFile
sf
)
2020-01-30 18:40:08 +00:00
liftEither $ readEither (LUTF8.toString out)
2020-01-31 16:46:06 +00:00
-------------------------------------
--[ Combined Github / Git actions ]--
-------------------------------------
2020-01-30 18:40:08 +00:00
-- | Same as 'prepareRepoForPR', but gets the auth from the config file
-- and parses the owner/repo from the given repo url string.
2020-01-31 16:38:29 +00:00
prepareRepoForPR' :: ( MonadIO m
, MonadReader Settings m
, MonadFail m
, MonadThrow m
)
=> ByteString -- ^ string that contains repo url
2020-01-30 18:40:08 +00:00
-> Maybe (Path b) -- ^ base path where the repo should be cloned
-> Maybe ByteString -- ^ PR branch name to switch to
2020-02-01 15:43:46 +00:00
-> ExceptT Error m ()
2020-01-31 16:38:29 +00:00
prepareRepoForPR' repoString mRepobase branch = do
2020-02-01 15:43:46 +00:00
UrlParseResult {..} <- (liftEither $ parseURL repoString) ?* uError
2020-01-30 22:12:46 +00:00
repobase <- case mRepobase of
2020-01-31 16:38:29 +00:00
Just r -> fmap Just $ liftIO $ toAbs r
Nothing -> basePath
prepareRepoForPR owner repo repobase branch
2020-01-30 18:40:08 +00:00
-- | Fork the repository to my account, clone it, add original upstream
-- as remote, optionally switch to the given branch.
2020-01-31 16:38:29 +00:00
prepareRepoForPR :: ( MonadIO m
, MonadReader Settings m
, MonadFail m
, MonadThrow m
)
=> Name Owner
2020-01-30 18:40:08 +00:00
-> Name Repo
-> Maybe (Path b) -- ^ base path where the repo should be cloned
-> Maybe ByteString -- ^ PR branch name to switch to
2020-02-01 15:43:46 +00:00
-> ExceptT Error m ()
2020-01-31 16:38:29 +00:00
prepareRepoForPR owner repo repobase branch = do
2020-01-30 18:40:08 +00:00
repodest <- case repobase of
Just rb ->
2020-01-31 16:38:29 +00:00
((rb </>) <$> (parseRel $ E.encodeUtf8 $ untagName repo))
>>= liftIO
. toAbs
Nothing -> (parseRel $ E.encodeUtf8 $ untagName repo) >>= liftIO . toAbs
2020-02-01 15:43:46 +00:00
ForkResult {..} <- (forkRepository owner repo) ?* (uError . show)
(ExceptT $ cloneRepository CloneSSH downstream repodest) ?* (uError . show)
(ExceptT $ setUpstream upstream repodest) ?* (uError . show)
2020-01-30 18:40:08 +00:00
case branch of
2020-02-01 15:43:46 +00:00
Just b -> (ExceptT $ createBranch b repodest) ?* (uError . show)
2020-01-30 18:40:08 +00:00
Nothing -> pure ()
2020-01-30 22:12:46 +00:00
lift $ _info
( "To change to the repo dir, run:\n\tcd "
<> (UTF8.toString $ toFilePath repodest)
)
2020-01-30 18:40:08 +00:00
2020-01-31 16:46:06 +00:00
-------------------
--[ Git actions ]--
-------------------
2020-01-30 18:40:08 +00:00
2020-01-31 16:38:29 +00:00
cloneRepository :: (MonadIO m, MonadFail m)
=> CloneMethod
2020-01-30 18:40:08 +00:00
-> Repo
-> Path b -- ^ full path where the repo should be cloned to
2020-01-31 16:38:29 +00:00
-> m (Either ProcessError ())
2020-01-30 18:40:08 +00:00
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!"
2020-01-31 16:38:29 +00:00
setUpstream :: (MonadIO m, MonadFail m)
=> Repo -- ^ upstream
2020-01-30 18:40:08 +00:00
-> Path b -- ^ full path to repo
2020-01-31 16:38:29 +00:00
-> m (Either ProcessError ())
2020-01-30 18:40:08 +00:00
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!"
2020-01-31 16:38:29 +00:00
createBranch :: MonadIO m
=> ByteString -- ^ branch name
2020-01-30 18:40:08 +00:00
-> Path b -- ^ full path to repo
2020-01-31 16:38:29 +00:00
-> m (Either ProcessError ())
2020-01-30 18:40:08 +00:00
createBranch branch repodir =
_runGit [u8 "-C", toFilePath repodir, u8 "checkout", u8 "-b", branch]
2020-01-31 16:46:06 +00:00
----------------------
--[ Github actions ]--
----------------------
forkRepository :: (MonadIO m, MonadReader Settings m)
=> Name Owner
-> Name Repo
-> ExceptT Error m ForkResult
forkRepository owner repo = do
upstream <- github_ (repositoryR owner repo)
downstream <- githubAuth (forkExistingRepoR owner repo Nothing)
pure $ ForkResult { .. }
2020-01-30 18:40:08 +00:00
-- | Same as deleteFork, but gets the auth from the config file
-- and parses the owner/repo from the given repo url string.
2020-01-31 16:38:29 +00:00
deleteFork' :: (MonadIO m, MonadReader Settings m)
=> ByteString
2020-02-01 15:43:46 +00:00
-> ExceptT Error m ()
2020-01-31 16:38:29 +00:00
deleteFork' repoString = do
2020-02-01 15:43:46 +00:00
UrlParseResult {..} <- (liftEither $ parseURL repoString) ?* uError
deleteFork owner repo
2020-01-30 18:40:08 +00:00
2020-01-31 16:38:29 +00:00
deleteFork :: (MonadIO m, MonadReader Settings m)
=> Name Owner
2020-01-30 18:40:08 +00:00
-> Name Repo
2020-01-31 16:46:06 +00:00
-> ExceptT Error m ()
2020-01-31 16:38:29 +00:00
deleteFork owner repo = do
2020-01-31 16:46:06 +00:00
github_ (repositoryR owner repo) >>= \case
2020-01-30 18:40:08 +00:00
(Repo { repoFork = Just True }) -> pure ()
2020-02-02 13:33:25 +00:00
_ -> throwError (uError "Not a fork")
2020-01-31 16:46:06 +00:00
githubAuth (deleteRepoR owner repo)
2020-01-31 14:54:41 +00:00
2020-01-31 16:38:29 +00:00
getForks :: (MonadIO m, MonadReader Settings m)
=> Maybe UTCTime
-> ExceptT Error m [Repo]
getForks mtime = do
2020-02-01 15:23:02 +00:00
user <- githubAuth userInfoCurrentR
let userName = untagName $ userLogin user
repos <- github_
(searchReposR $ mconcat [T.pack "user:", userName, T.pack " fork:only"])
2020-01-31 18:34:05 +00:00
pure $ sortBy (\x y -> compare (repoUpdatedAt y) (repoUpdatedAt x)) $ filter
2020-01-31 16:38:29 +00:00
(\case
Repo { repoFork = Just True, repoUpdatedAt = Just t } ->
maybe True (t >=) mtime
_ -> False
)
2020-02-01 15:23:02 +00:00
(toList $ searchResultResults repos)
2020-01-30 18:40:08 +00:00
2020-02-02 13:33:25 +00:00
data GistContent = GistContent {
content :: T.Text
} deriving (Show, Eq)
data GistRequest = GistRequest {
description :: T.Text
, public :: Bool
, files :: HashMap T.Text GistContent
} deriving (Show, Eq)
postGistStdin :: (MonadIO m, MonadReader Settings m, MonadThrow m)
=> T.Text -- ^ description
-> Bool -- ^ whether to be public
-> ExceptT Error m Gist
postGistStdin description public = do
content <- liftIO T.getContents
let files = H.fromList [(T.pack "stdout", GistContent content)]
postGist GistRequest { .. }
postGistFiles :: (MonadIO m, MonadReader Settings m, MonadThrow m)
=> [AnyPath] -- ^ files
-> T.Text -- ^ description
-> Bool -- ^ whether to be public
-> ExceptT Error m Gist
postGistFiles files' description public = do
files <- liftIO $ fmap H.fromList $ for files' $ \(AnyPath file) -> do
contents <- (E.decodeUtf8 . L.toStrict) <$> readFile file
filename <- (E.decodeUtf8 . toFilePath) <$> basename file
pure (filename, GistContent contents)
postGist GistRequest { .. }
postGist :: (MonadIO m, MonadReader Settings m)
=> GistRequest
-> ExceptT Error m Gist
postGist greq = githubAuth (command Post [T.pack "gists"] (encode greq))
2020-01-30 18:40:08 +00:00
2020-02-02 14:34:20 +00:00
listGists :: (MonadIO m, MonadReader Settings m)
=> Maybe UTCTime
-> ExceptT Error m [Gist]
listGists mtime = do
let queryString = case mtime of
Just time -> [(u8 "since", Just $ UTF8.fromString $ iso8601Show time)]
Nothing -> []
V.toList <$> githubAuth (pagedQuery [T.pack "gists"] queryString FetchAll)
2020-01-31 16:46:06 +00:00
2020-01-30 18:40:08 +00:00
---------------
--[ 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'
)
2020-01-31 22:41:47 +00:00
*> takeWhile1 (/= _slash)
2020-01-30 18:40:08 +00:00
<* word8 _slash
)
2020-01-31 23:26:40 +00:00
<*> parseRepoName
2020-01-30 18:40:08 +00:00
where
str = string . u8
empty' = str ""
2020-01-31 23:26:40 +00:00
parseRepoName :: Parser ByteString
parseRepoName = do
c <- fmap B.singleton anyWord8
r <- many1' ((str ".git" <* endOfInput) <|> fmap B.singleton anyWord8)
if last r == u8 ".git"
then pure $ mconcat (c : (init r))
else pure (mconcat (c : r)) <* endOfInput
2020-01-30 18:40:08 +00:00
---------------
--[ Helpers ]--
---------------
u8 :: String -> ByteString
u8 = UTF8.fromString
2020-01-31 16:38:29 +00:00
_clone :: MonadIO m => ByteString -> ByteString -> m (Either ProcessError ())
2020-01-30 18:40:08 +00:00
_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
2020-01-31 16:38:29 +00:00
_runGit :: MonadIO m => [ByteString] -> m (Either ProcessError ())
_runGit args = liftIO $ do
2020-01-30 18:40:08 +00:00
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
2020-01-30 22:12:46 +00:00
2020-01-31 16:38:29 +00:00
_info :: MonadIO m => String -> m ()
_info = liftIO . _stderr . color Green
_warn :: MonadIO m => String -> m ()
_warn = liftIO . _stderr . color Yellow
_err :: MonadIO m => String -> m ()
_err = liftIO . _stderr . color Red
_stderr :: MonadIO m => String -> m ()
_stderr = liftIO . hPutStrLn stderr
auth :: MonadReader Settings m => m Auth
auth = asks _auth
basePath :: MonadReader Settings m => m (Maybe (Path Abs))
basePath = asks _basePath
2020-01-30 22:12:46 +00:00
2020-01-31 16:38:29 +00:00
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
2020-01-30 22:12:46 +00:00
2020-01-31 16:38:29 +00:00
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
2020-02-01 15:43:46 +00:00
-- | Flipped 'withExceptT'.
(?*) :: Functor m => ExceptT e m a -> (e -> e') -> ExceptT e' m a
(?*) = flip withExceptT
uError :: String -> Error
uError = UserError . T.pack
2020-02-02 13:33:25 +00:00
$(deriveJSON defaultOptions 'GistContent)
$(deriveJSON defaultOptions 'GistRequest)