Add gist functionality
This commit is contained in:
parent
ee11c131ef
commit
f1186c3b11
213
app/Main.hs
213
app/Main.hs
@ -13,12 +13,15 @@ import Data.Functor ( (<&>) )
|
||||
import Data.Maybe
|
||||
import Data.Semigroup ( (<>) )
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Data.Time.Calendar
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Format
|
||||
import Data.Time.Format.ISO8601
|
||||
import Data.Traversable
|
||||
import GHup
|
||||
import GitHub.Auth
|
||||
import GitHub.Data.Gists
|
||||
import GitHub.Data.Repos
|
||||
import GitHub.Data.URL
|
||||
import HPath
|
||||
@ -38,6 +41,7 @@ data Command
|
||||
| Config ConfigOptions
|
||||
| Del DelOptions
|
||||
| ListForks ListForkOptions
|
||||
| CreateGist CreateGistOptions
|
||||
|
||||
data ForkOptions = ForkOptions
|
||||
{
|
||||
@ -56,17 +60,66 @@ data ConfigOptions = ConfigOptions {
|
||||
, bPath :: Maybe ByteString
|
||||
}
|
||||
|
||||
|
||||
data DelOptions = DelOptions {
|
||||
del :: ByteString
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
|
||||
opts :: Parser Command
|
||||
opts = subparser
|
||||
( 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
|
||||
"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"))
|
||||
)
|
||||
)
|
||||
|
||||
configOpts :: Parser ConfigOptions
|
||||
@ -115,68 +168,114 @@ lForkOpts = ListForkOptions <$> optional
|
||||
)
|
||||
)
|
||||
|
||||
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)"
|
||||
)
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
-- wrapper to run effects with settings
|
||||
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
|
||||
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
|
||||
|
||||
-- fork
|
||||
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
|
||||
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
|
||||
-- config
|
||||
Config (ConfigOptions {..}) -> do
|
||||
p <- maybe (pure Nothing) (fmap Just . parseAbs) bPath
|
||||
writeSettings (Settings (OAuth oAuth) p) <&> Right
|
||||
|
||||
-- delete
|
||||
Del (DelOptions {..} ) -> run $ deleteFork' del
|
||||
-- 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
|
||||
-- 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
|
||||
|
||||
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 ()
|
||||
|
||||
-- print error, if any
|
||||
case e of
|
||||
|
||||
@ -18,7 +18,8 @@ library
|
||||
exposed-modules: GHup
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends: attoparsec ^>= 0.13
|
||||
build-depends: aeson ^>= 1.4
|
||||
, attoparsec ^>= 0.13
|
||||
, base ^>= 4.12
|
||||
, bytestring ^>= 0.10
|
||||
, github ^>= 0.24
|
||||
@ -32,6 +33,7 @@ library
|
||||
, text ^>= 1.2
|
||||
, time ^>= 1.9
|
||||
, unix ^>= 2.7
|
||||
, unordered-containers ^>= 0.2
|
||||
, utf8-string ^>= 1.0
|
||||
, vector ^>= 0.12
|
||||
, word8 ^>= 0.1
|
||||
|
||||
63
lib/GHup.hs
63
lib/GHup.hs
@ -2,15 +2,18 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module GHup
|
||||
(
|
||||
-- * Types
|
||||
ForkResult(..)
|
||||
AnyPath(..)
|
||||
, ForkResult(..)
|
||||
, CloneMethod(..)
|
||||
, ProcessError(..)
|
||||
, Settings(..)
|
||||
@ -27,6 +30,9 @@ module GHup
|
||||
, deleteFork'
|
||||
, deleteFork
|
||||
, getForks
|
||||
, postGistStdin
|
||||
, postGistFiles
|
||||
, postGist
|
||||
-- * Parsers
|
||||
, parseURL
|
||||
, ghURLParser
|
||||
@ -34,6 +40,7 @@ module GHup
|
||||
, _info
|
||||
, _warn
|
||||
, _err
|
||||
, uError
|
||||
)
|
||||
where
|
||||
|
||||
@ -42,20 +49,28 @@ import Control.Exception.Safe
|
||||
import Control.Monad.Except hiding ( fail )
|
||||
import Control.Monad.Fail
|
||||
import Control.Monad.Reader hiding ( fail )
|
||||
import Data.Aeson
|
||||
import Data.Aeson.TH
|
||||
import Data.Attoparsec.ByteString
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified Data.ByteString.Lazy.UTF8 as LUTF8
|
||||
import Data.Functor ( (<&>) )
|
||||
import qualified Data.HashMap.Strict as H
|
||||
import Data.HashMap.Strict ( HashMap )
|
||||
import Data.List
|
||||
import Data.Proxy
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.IO as T
|
||||
import Data.Traversable
|
||||
import Data.Time.Clock
|
||||
import Data.Word8
|
||||
import GHC.Exts ( toList )
|
||||
import GitHub.Auth
|
||||
import GitHub.Data.Gists
|
||||
import GitHub.Data.Name
|
||||
import GitHub.Data.URL
|
||||
import GitHub.Data.Request
|
||||
@ -130,6 +145,8 @@ instance Read (Path Abs) where
|
||||
_ -> []
|
||||
|
||||
|
||||
data AnyPath = forall a . AnyPath (Path a)
|
||||
|
||||
|
||||
|
||||
|
||||
@ -320,7 +337,7 @@ deleteFork :: (MonadIO m, MonadReader Settings m)
|
||||
deleteFork owner repo = do
|
||||
github_ (repositoryR owner repo) >>= \case
|
||||
(Repo { repoFork = Just True }) -> pure ()
|
||||
_ -> throwError (uError "Not a fork")
|
||||
_ -> throwError (uError "Not a fork")
|
||||
githubAuth (deleteRepoR owner repo)
|
||||
|
||||
|
||||
@ -341,6 +358,45 @@ getForks mtime = do
|
||||
(toList $ searchResultResults repos)
|
||||
|
||||
|
||||
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))
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
@ -462,3 +518,6 @@ github_ req = do
|
||||
|
||||
uError :: String -> Error
|
||||
uError = UserError . T.pack
|
||||
|
||||
$(deriveJSON defaultOptions 'GistContent)
|
||||
$(deriveJSON defaultOptions 'GistRequest)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user