Add gist functionality

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
-  <> command "config"     (Config <$> (info (configOpts <**> helper) (progDesc "Set ghup config (such as OAuth)")))
+      "fork"
-  <> command "delete"     (Del <$> (info (delOpts <**> helper) (progDesc "Delete a forked repository")))
+      (Fork <$> (info (forkOpts <**> helper) (progDesc "Fork a repository")))
-  <> command "list-forks" (ListForks <$> (info (lForkOpts <**> helper) (progDesc "List my forks")))
+  <> 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
+  let
-        settings <- exceptT
+    run e = do
-              (\_ -> die
+      settings <-
-                  . color Red
+        exceptT
-                  $ "Could not get settings, make sure to run 'ghup config' first"
+            (\_ ->
-              )
+              die
-              pure
+                . color Red
-            $ getSettings
+                $ "Could not get settings, make sure to run 'ghup config' first"
-        (flip runReaderT) settings . runExceptT . withExceptT show $ e
+            )
-  e <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm) >>= \case
+            pure
+          $ getSettings
+      (flip runReaderT) settings . runExceptT . withExceptT show $ e
+  e <-
+    customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
+      >>= \case
 
     -- fork
-    Fork (ForkOptions {..}) -> run $ do
+            Fork (ForkOptions {..}) -> run $ do
-      case repoBasePath of
+              case repoBasePath of
-        Just rbp -> case parseAbs rbp of
+                Just rbp -> case parseAbs rbp of
-          Just p  -> prepareRepoForPR' repo (Just p) newBranch
+                  Just p -> prepareRepoForPR' repo (Just p) newBranch
-          Nothing -> liftIO $ die (color Red $ "Repo path must be absolute")
+                  Nothing ->
-        Nothing -> prepareRepoForPR' repo Nothing newBranch
+                    liftIO $ die (color Red $ "Repo path must be absolute")
+                Nothing -> prepareRepoForPR' repo Nothing newBranch
 
-    -- config
+            -- config
-    Config (ConfigOptions {..}) -> do
+            Config (ConfigOptions {..}) -> do
-      p <- maybe (pure Nothing) (fmap Just . parseAbs) bPath
+              p <- maybe (pure Nothing) (fmap Just . parseAbs) bPath
-      writeSettings (Settings (OAuth oAuth) p) <&> Right
+              writeSettings (Settings (OAuth oAuth) p) <&> Right
 
-    -- delete
+            -- delete
-    Del       (DelOptions {..}     ) -> run $ deleteFork' del
+            Del       (DelOptions {..}     ) -> run $ deleteFork' del
 
-    -- list-forks
+            -- list-forks
-    ListForks (ListForkOptions {..}) -> run $ do
+            ListForks (ListForkOptions {..}) -> run $ do
-      mtime <- liftIO $ case lSince of
+              mtime <- liftIO $ case lSince of
-        Just t' -> do
+                Just t' -> do
-          dt <- getCurrentDateTime
+                  dt <- getCurrentDateTime
-          let mt =
+                  let
-                either (const Nothing) Just . parseDate dt . UTF8.toString $ t'
+                    mt =
-          pure $ mt >>= \t ->
+                      either (const Nothing) Just
-            (parseTimeM
+                        . parseDate dt
-              True
+                        . UTF8.toString
-              defaultTimeLocale
+                        $ t'
-              "%Y-%-m-%-d"
+                  pure $ mt >>= \t ->
-              (show (year t) <> "-" <> show (month t) <> "-" <> show (day t)) :: Maybe
+                    (parseTimeM
-                UTCTime
+                      True
-            )
+                      defaultTimeLocale
-        Nothing -> pure Nothing
+                      "%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

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

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)