diff --git a/app/Main.hs b/app/Main.hs index 2b24c49..8ba635b 100644 --- a/app/Main.hs +++ b/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 diff --git a/ghup.cabal b/ghup.cabal index 41aa611..d1e834b 100644 --- a/ghup.cabal +++ b/ghup.cabal @@ -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 diff --git a/lib/GHup.hs b/lib/GHup.hs index f27875e..a61d996 100644 --- a/lib/GHup.hs +++ b/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)