ghup/app/Main.hs

284 lines
8.1 KiB
Haskell
Raw Normal View History

2020-01-30 18:40:08 +00:00
module Main where
2020-01-31 16:38:29 +00:00
import Control.Error.Util
2020-01-31 14:54:41 +00:00
import Control.Monad.Except
2020-01-31 16:38:29 +00:00
import Control.Monad.Reader
2020-01-30 18:40:08 +00:00
import Data.ByteString ( ByteString )
2020-01-31 14:54:41 +00:00
import qualified Data.ByteString.UTF8 as UTF8
import Data.Dates ( getCurrentDateTime
, parseDate
, DateTime(..)
)
2020-01-30 18:40:08 +00:00
import Data.Functor ( (<&>) )
2020-01-31 18:34:05 +00:00
import Data.Maybe
2020-01-30 18:40:08 +00:00
import Data.Semigroup ( (<>) )
2020-01-31 14:54:41 +00:00
import qualified Data.Text as T
2020-02-02 13:33:25 +00:00
import qualified Data.Text.Encoding as E
2020-01-31 18:34:05 +00:00
import Data.Time.Calendar
2020-01-31 14:54:41 +00:00
import Data.Time.Clock
import Data.Time.Format
2020-01-31 18:34:05 +00:00
import Data.Time.Format.ISO8601
2020-02-02 13:33:25 +00:00
import Data.Traversable
2020-01-30 18:40:08 +00:00
import GHup
import GitHub.Auth
2020-02-02 13:33:25 +00:00
import GitHub.Data.Gists
2020-01-31 14:54:41 +00:00
import GitHub.Data.Repos
2020-01-31 16:38:29 +00:00
import GitHub.Data.URL
2020-01-30 18:40:08 +00:00
import HPath
import Options.Applicative
2020-01-30 22:12:46 +00:00
import System.Console.Pretty
2020-01-30 18:40:08 +00:00
import System.Exit
2020-01-31 22:18:45 +00:00
import Text.Layout.Table
2020-01-30 18:40:08 +00:00
data Options = Options
{ optCommand :: Command
}
data Command
= Fork ForkOptions
| Config ConfigOptions
| Del DelOptions
2020-01-31 14:54:41 +00:00
| ListForks ListForkOptions
2020-02-02 13:33:25 +00:00
| CreateGist CreateGistOptions
2020-01-30 18:40:08 +00:00
data ForkOptions = ForkOptions
{
repo :: ByteString
, newBranch :: Maybe ByteString
, repoBasePath :: Maybe ByteString
}
2020-01-31 14:54:41 +00:00
data ListForkOptions = ListForkOptions
{
lSince :: Maybe ByteString
}
2020-01-30 18:40:08 +00:00
data ConfigOptions = ConfigOptions {
2020-01-30 22:12:46 +00:00
oAuth :: ByteString
, bPath :: Maybe ByteString
2020-01-30 18:40:08 +00:00
}
data DelOptions = DelOptions {
del :: ByteString
}
2020-02-02 13:33:25 +00:00
data CreateGistOptions = CreateGistOptions {
input :: Input
, description :: Maybe ByteString
, private :: Bool
}
data Input
= FileInput [ByteString]
| StdInput
fileInput :: Parser Input
fileInput =
FileInput
<$> (some
(strOption
(long "file" <> short 'f' <> metavar "FILENAME" <> help
"Input one or more files"
)
)
)
stdInput :: Parser Input
stdInput = flag' StdInput (long "stdin" <> help "Read from stdin")
inputP :: Parser Input
inputP = fileInput <|> stdInput
2020-01-30 18:40:08 +00:00
opts :: Parser Command
opts = subparser
2020-02-02 13:33:25 +00:00
( command
"fork"
(Fork <$> (info (forkOpts <**> helper) (progDesc "Fork a repository")))
<> command
"config"
( Config
<$> (info (configOpts <**> helper)
(progDesc "Set ghup config (such as OAuth)")
)
)
<> command
"delete"
( Del
<$> (info (delOpts <**> helper)
(progDesc "Delete a forked repository")
)
)
<> command
"list-forks"
( ListForks
<$> (info (lForkOpts <**> helper) (progDesc "List my forks"))
)
<> command
"gist"
(CreateGist <$> (info (cGistOpts <**> helper) (progDesc "Create gist"))
)
2020-01-30 18:40:08 +00:00
)
configOpts :: Parser ConfigOptions
2020-01-30 22:12:46 +00:00
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"
)
)
2020-01-30 18:40:08 +00:00
forkOpts :: Parser ForkOptions
forkOpts =
ForkOptions
<$> strOption
(short 'r' <> long "repo" <> metavar "REPO" <> help
"The repository to fork"
)
<*> optional
(strOption
(short 'b' <> long "branch" <> metavar "BRANCH" <> help
"The branch to create after cloning the fork"
)
)
<*> optional
(strOption
(short 'p' <> long "repo-path" <> metavar "REPO_PATH" <> help
"The base path where to clone the repository to"
)
)
delOpts :: Parser DelOptions
delOpts = DelOptions <$> strOption
(short 'r' <> long "repo" <> metavar "REPO" <> help "The REPO fork to delete")
2020-01-31 14:54:41 +00:00
lForkOpts :: Parser ListForkOptions
lForkOpts = ListForkOptions <$> optional
(strOption
(short 's' <> long "since" <> metavar "SINCE" <> help
"The repository to fork"
)
)
2020-02-02 13:33:25 +00:00
cGistOpts :: Parser CreateGistOptions
cGistOpts =
CreateGistOptions
<$> inputP
<*> optional
(strOption
(short 'd' <> long "description" <> metavar "DESCRIPTION" <> help
"The description of the gist (optional)"
)
)
<*> switch
(short 'p' <> long "private" <> help
"Whether gist should be private (default: public)"
)
2020-01-30 18:40:08 +00:00
main :: IO ()
main = do
2020-01-31 22:22:37 +00:00
-- wrapper to run effects with settings
2020-02-02 13:33:25 +00:00
let
run e = do
settings <-
exceptT
(\_ ->
die
. color Red
$ "Could not get settings, make sure to run 'ghup config' first"
)
pure
$ getSettings
(flip runReaderT) settings . runExceptT . withExceptT show $ e
e <-
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \case
2020-01-31 22:22:37 +00:00
-- fork
2020-02-02 13:33:25 +00:00
Fork (ForkOptions {..}) -> run $ do
case repoBasePath of
Just rbp -> case parseAbs rbp of
Just p -> prepareRepoForPR' repo (Just p) newBranch
Nothing ->
liftIO $ die (color Red $ "Repo path must be absolute")
Nothing -> prepareRepoForPR' repo Nothing newBranch
-- config
Config (ConfigOptions {..}) -> do
p <- maybe (pure Nothing) (fmap Just . parseAbs) bPath
writeSettings (Settings (OAuth oAuth) p) <&> Right
-- delete
Del (DelOptions {..} ) -> run $ deleteFork' del
-- list-forks
ListForks (ListForkOptions {..}) -> run $ do
mtime <- liftIO $ case lSince of
Just t' -> do
dt <- getCurrentDateTime
let
mt =
either (const Nothing) Just
. parseDate dt
. UTF8.toString
$ t'
pure $ mt >>= \t ->
(parseTimeM
True
defaultTimeLocale
"%Y-%-m-%-d"
(show (year t) <> "-" <> show (month t) <> "-" <> show
(day t)
) :: Maybe UTCTime
)
Nothing -> pure Nothing
forks <- withExceptT show $ getForks mtime
let
formatted =
gridString
[column expand left def def, column expand left def def]
$ fmap
(\Repo {..} ->
[ (T.unpack . getUrl $ repoHtmlUrl)
, formatShow (iso8601Format :: Format Day)
(utctDay $ fromJust repoUpdatedAt)
]
)
forks
liftIO $ putStrLn $ formatted
pure ()
-- gist
CreateGist (CreateGistOptions {..}) -> run $ do
let desc = maybe T.empty E.decodeUtf8 description
public = not private
gist <- case input of
StdInput -> postGistStdin desc public
FileInput files -> do
files' <- for files $ \file -> do
let absPath = parseAbs file
let relPath = parseRel file
case (absPath, relPath) of
(Just a, _) -> pure $ AnyPath $ a
(_, Just a) -> pure $ AnyPath $ a
_ -> throwError (uError "Could not parse path")
postGistFiles files' desc public
liftIO $ putStrLn $ T.unpack $ getUrl $ gistHtmlUrl gist
2020-01-31 22:22:37 +00:00
-- print error, if any
2020-01-30 18:40:08 +00:00
case e of
2020-01-31 16:38:29 +00:00
Right () -> pure ()
2020-01-30 22:12:46 +00:00
Left t -> die (color Red $ t)