Prettify

README.md

@@ -1,3 +1,40 @@
 # ghup
 
 Simple Github helper for myself.
+
+## Installation
+
+If you don't have haskell GHC and cabal installed,
+follow [ghcup](https://www.haskell.org/ghcup/) first.
+
+Then issue:
+
+```sh
+$ cabal v2-install ghup
+```
+
+## Usage
+
+First you need to set the github OAuth (no other method currently supported)
+for API access:
+
+```
+ghup config --oauth "<your-github-token>"
+```
+
+Then follow the help page:
+
+```
+Usage: ghup COMMAND
+
+Available options:
+  -h,--help                Show this help text
+
+Available commands:
+  fork                     Fork a repository
+  config                   Set ghup config (such as OAuth)
+  delete                   Delete a forked repository
+  list-forks               List my forks
+  gistc                    Create gist
+  gistl                    List gists
+```

app/Main.hs

@@ -1,7 +1,6 @@
 module Main where
 
 import           Control.Error.Util
-import           Control.Monad
 import           Control.Monad.Except
 import           Control.Monad.Reader
 import           Data.ByteString                ( ByteString )
@@ -11,23 +10,25 @@ import           Data.Dates                     ( getCurrentDateTime
                                                 , DateTime(..)
                                                 )
 import           Data.Functor                   ( (<&>) )
-import           Data.List
+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.Clock.POSIX
 import           Data.Time.Format
+import           Data.Time.Format.ISO8601
+import           Data.Traversable
 import           GHup
 import           GitHub.Auth
-import           GitHub.Data.Definitions
+import           GitHub.Data.Gists
-import           GitHub.Data.Name
 import           GitHub.Data.Repos
 import           GitHub.Data.URL
 import           HPath
 import           Options.Applicative
-import           Safe
 import           System.Console.Pretty
 import           System.Exit
+import           Text.Layout.Table
 
 
 
@@ -40,6 +41,8 @@ data Command
   | Config ConfigOptions
   | Del DelOptions
   | ListForks ListForkOptions
+  | CreateGist CreateGistOptions
+  | ListGist ListGistOptions
 
 data ForkOptions = ForkOptions
   {
@@ -58,17 +61,75 @@ 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
+
+data ListGistOptions = ListGistOptions
+  {
+    lgSince        :: Maybe ByteString
+  , lgDesc         :: Bool
+  }
+
+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) idm))
+  (  command
-  <> command "config"     (Config <$> (info (configOpts <**> helper) idm))
+      "fork"
-  <> command "delete"     (Del <$> (info (delOpts <**> helper) idm))
+      (Fork <$> (info (forkOpts <**> helper) (progDesc "Fork a repository")))
-  <> command "list-forks" (ListForks <$> (info (lForkOpts <**> helper) idm))
+  <> 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
+       "gistc"
+       (CreateGist <$> (info (cGistOpts <**> helper) (progDesc "Create gist"))
+       )
+  <> command
+       "gistl"
+       (ListGist <$> (info (lGistOpts <**> helper) (progDesc "List gists")))
   )
 
 configOpts :: Parser ConfigOptions
@@ -117,52 +178,157 @@ 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)"
+          )
+
+lGistOpts :: Parser ListGistOptions
+lGistOpts =
+  ListGistOptions
+    <$> optional
+          (strOption
+            (short 's' <> long "since" <> metavar "SINCE" <> help
+              "The repository to fork"
+            )
+          )
+    <*> switch
+          (short 'd' <> long "descriptions" <> help
+            "Whether to show descriptions (default: False)"
+          )
+
 
 main :: IO ()
 main = do
+  -- wrapper to run effects with settings
   let
     run e = do
       settings <-
         exceptT
-            ( const die
+            (\_ ->
-            . color Red
+              die
-            $ "Could not get settings, make sure to run 'ghup config' first"
+                . color Red
+                $ "Could not get settings, make sure to run 'ghup config' first"
             )
             pure
           $ getSettings
       (flip runReaderT) settings . runExceptT . withExceptT show $ e
-  e <- execParser (info (opts <**> helper) idm) >>= \case
+  e <-
-    Fork (ForkOptions {..}) -> run $ do
+    customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
-      case repoBasePath of
+      >>= \case
-        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 (ConfigOptions {..}) -> do
-      p <- maybe (pure Nothing) (fmap Just . parseAbs) bPath
-      writeSettings (Settings (OAuth oAuth) p) <&> Right
-    Del       (DelOptions {..}     ) -> run $ deleteFork' del
-    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
+    -- fork
-      let formatted = intercalate "\n"
+            Fork (ForkOptions {..}) -> run $ do
-            $ fmap (\Repo {..} -> T.unpack . getUrl $ repoHtmlUrl) forks
+              case repoBasePath of
-      liftIO $ putStrLn $ formatted
+                Just rbp -> case parseAbs rbp of
-      pure ()
+                  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 <- parseSince lSince
+              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 ()
+
+            -- gistc
+            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
+
+            -- gistl
+            ListGist (ListGistOptions {..}) -> run $ do
+              mtime <- parseSince lgSince
+              gists <- listGists mtime
+              let
+                formatted =
+                  gridString
+                      (  [column expand left def def]
+                      <> (if lgDesc then [column expand left def def] else [])
+                      <> [column expand left def def]
+                      )
+                    $ fmap
+                        (\Gist {..} ->
+                          [(T.unpack . getUrl $ gistHtmlUrl)]
+                            <> (if lgDesc
+                                 then
+                                   [ T.unpack $ fromMaybe (T.pack "(No desc)")
+                                                          gistDescription
+                                   ]
+                                 else []
+                               )
+                            <> [ formatShow (iso8601Format :: Format Day)
+                                            (utctDay gistUpdatedAt)
+                               ]
+                        )
+                        gists
+              liftIO $ putStrLn $ formatted
+
+
+
+  -- print error, if any
   case e of
     Right () -> pure ()
     Left  t  -> die (color Red $ t)
+
+ where
+  parseSince lSince = do
+    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

cabal.project

@@ -1 +1,5 @@
 packages: ./ghup.cabal
+
+with-compiler: ghc-8.6.5
+
+index-state: 2020-01-31T21:11:24Z

cabal.project.freeze

@@ -1,4 +1,5 @@
-constraints: any.Cabal ==2.4.0.1,
+constraints: any.Cabal ==3.0.0.0,
+             Cabal -bundled-binary-generic,
              any.IfElse ==0.85,
              any.StateVar ==1.2,
              any.abstract-deque ==0.3,
@@ -25,6 +26,8 @@ constraints: any.Cabal ==2.4.0.1,
              any.base ==4.12.0.0,
              any.base-compat ==0.11.1,
              any.base-orphans ==0.8.2,
+             any.base-unicode-symbols ==0.2.4.2,
+             base-unicode-symbols +base-4-8 -old-base,
              any.base16-bytestring ==0.1.1.6,
              any.basement ==0.0.11,
              any.bifunctors ==5.5.7,
@@ -51,9 +54,11 @@ constraints: any.Cabal ==2.4.0.1,
              any.cryptonite ==0.26,
              cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse,
              any.data-default-class ==0.1.2.0,
+             any.data-default-instances-base ==0.1.0.1,
+             any.dates ==0.2.3.0,
              any.deepseq ==1.4.4.0,
              any.deepseq-generics ==0.2.0.0,
-             any.directory ==1.3.3.0,
+             any.directory ==1.3.6.0,
              any.distributive ==0.6.1,
              distributive +semigroups +tagged,
              any.dlist ==0.8.0.7,
@@ -101,7 +106,7 @@ constraints: any.Cabal ==2.4.0.1,
              any.monad-control ==1.0.2.3,
              any.mtl ==2.2.2,
              any.network ==3.1.1.1,
-             any.network-uri ==2.6.1.0,
+             any.network-uri ==2.6.2.0,
              any.optparse-applicative ==0.15.1.0,
              any.parsec ==3.1.13.0,
              any.pem ==0.2.4,
@@ -110,7 +115,7 @@ constraints: any.Cabal ==2.4.0.1,
              any.pretty ==1.1.3.6,
              any.pretty-terminal ==0.1.0.0,
              any.primitive ==0.7.0.0,
-             any.process ==1.6.5.0,
+             any.process ==1.6.7.0,
              any.profunctors ==5.5.1,
              any.random ==1.1,
              any.rts ==1.0,
@@ -129,13 +134,15 @@ constraints: any.Cabal ==2.4.0.1,
              any.streamly ==0.7.0,
              streamly -benchmark -debug -dev -examples -examples-sdl -has-llvm -inspection -no-charts -no-fusion -streamk,
              any.streamly-bytestring ==0.1.0.1,
+             any.syb ==0.7.1,
+             any.table-layout ==0.8.0.5,
              any.tagged ==0.8.6,
              tagged +deepseq +transformers,
              any.template-haskell ==2.14.0.0,
              any.text ==1.2.3.1,
              any.text-binary ==0.2.1.1,
              any.th-abstraction ==0.3.1.0,
-             any.time ==1.8.0.2,
+             any.time ==1.9.3,
              any.time-compat ==1.9.2.2,
              time-compat -old-locale,
              any.tls ==1.5.3,

ghup.cabal

@@ -18,23 +18,25 @@ library
   exposed-modules:     GHup
   -- other-modules:
   -- other-extensions:
-  build-depends:         attoparsec      ^>= 0.13
+  build-depends:         aeson                ^>= 1.4
-                       , base            ^>= 4.12
+                       , attoparsec           ^>= 0.13
-                       , bytestring      ^>= 0.10
+                       , base                 ^>= 4.12
-                       , github          ^>= 0.24
+                       , bytestring           ^>= 0.10
-                       , hpath           ^>= 0.11
+                       , github               ^>= 0.24
-                       , hpath-io        ^>= 0.13.1
+                       , hpath                ^>= 0.11
-                       , http-client     ^>= 0.6.4
+                       , hpath-io             ^>= 0.13.1
-                       , mtl             ^>= 2.2
+                       , http-client          ^>= 0.6.4
-                       , pretty-terminal ^>= 0.1
+                       , mtl                  ^>= 2.2
-                       , safe-exceptions ^>= 0.1
+                       , pretty-terminal      ^>= 0.1
-                       , streamly        ^>= 0.7
+                       , safe-exceptions      ^>= 0.1
-                       , text            ^>= 1.2
+                       , streamly             ^>= 0.7
-                       , time            ^>= 1.8
+                       , text                 ^>= 1.2
-                       , unix            ^>= 2.7
+                       , time                 ^>= 1.9
-                       , utf8-string     ^>= 1.0
+                       , unix                 ^>= 2.7
-                       , vector          ^>= 0.12
+                       , unordered-containers ^>= 0.2
-                       , word8           ^>= 0.1
+                       , utf8-string          ^>= 1.0
+                       , vector               ^>= 0.12
+                       , word8                ^>= 0.1
   hs-source-dirs:      lib
   ghc-options:         -Wall
   default-language:    Haskell2010
@@ -54,11 +56,12 @@ executable ghup
                        , mtl                  ^>= 2.2
                        , optparse-applicative ^>= 0.15
                        , pretty-terminal      ^>= 0.1
-                       , safe                 ^>= 0.3
+                       , table-layout         ^>= 0.8
                        , text                 ^>= 1.2
-                       , time                 ^>= 1.8
+                       , time                 ^>= 1.9
                        , utf8-string          ^>= 1.0
   hs-source-dirs:      app
+  ghc-options:         -Wall
   default-language:    Haskell2010
   default-extensions:  LambdaCase, MultiWayIf, RecordWildCards, TupleSections
 

lib/GHup.hs

@@ -1,16 +1,19 @@
-{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE DataKinds                 #-}
-{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE DeriveGeneric             #-}
-{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE FlexibleContexts          #-}
-{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE FlexibleInstances         #-}
-{-# LANGUAGE QuasiQuotes        #-}
+{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE QuasiQuotes               #-}
-{-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE StandaloneDeriving        #-}
-{-# OPTIONS_GHC -Wno-orphans    #-}
+{-# LANGUAGE TemplateHaskell           #-}
+{-# LANGUAGE TypeFamilies              #-}
+{-# OPTIONS_GHC -Wno-orphans           #-}
 
 module GHup
   (
   -- * Types
-    ForkResult(..)
+    AnyPath(..)
+  , ForkResult(..)
   , CloneMethod(..)
   , ProcessError(..)
   , Settings(..)
@@ -27,6 +30,10 @@ module GHup
   , deleteFork'
   , deleteFork
   , getForks
+  , postGistStdin
+  , postGistFiles
+  , postGist
+  , listGists
   -- * Parsers
   , parseURL
   , ghURLParser
@@ -34,6 +41,7 @@ module GHup
   , _info
   , _warn
   , _err
+  , uError
   )
 where
 
@@ -42,21 +50,36 @@ 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.Time.Format.ISO8601
+import qualified Data.Vector                   as V
 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
 import           GitHub.Endpoints.Repos
+import           GitHub.Endpoints.Search
+import           GitHub.Endpoints.Users
 import           GitHub.Request
 import           HPath
 import           HPath.IO
@@ -125,6 +148,8 @@ instance Read (Path Abs) where
           _ -> []
 
 
+data AnyPath = forall a . AnyPath (Path a)
+
 
 
 
@@ -182,9 +207,9 @@ getSettings = (fromEnv <|> fromFile)
 
 
 
-    ----------------------------
+    -------------------------------------
-    --[ Github / Git actions ]--
+    --[ Combined Github / Git actions ]--
-    ----------------------------
+    -------------------------------------
 
 
 -- | Same as 'prepareRepoForPR', but gets the auth from the config file
@@ -197,9 +222,9 @@ prepareRepoForPR' :: ( MonadIO m
                   => ByteString       -- ^ string that contains repo url
                   -> Maybe (Path b)   -- ^ base path where the repo should be cloned
                   -> Maybe ByteString -- ^ PR branch name to switch to
-                  -> ExceptT String m ()
+                  -> ExceptT Error m ()
 prepareRepoForPR' repoString mRepobase branch = do
-  UrlParseResult {..} <- liftEither $ parseURL repoString
+  UrlParseResult {..} <- (liftEither $ parseURL repoString) ?* uError
   repobase            <- case mRepobase of
     Just r  -> fmap Just $ liftIO $ toAbs r
     Nothing -> basePath
@@ -218,7 +243,7 @@ prepareRepoForPR :: ( MonadIO m
                  -> Name Repo
                  -> Maybe (Path b)   -- ^ base path where the repo should be cloned
                  -> Maybe ByteString -- ^ PR branch name to switch to
-                 -> ExceptT String m ()
+                 -> ExceptT Error m ()
 prepareRepoForPR owner repo repobase branch = do
   repodest <- case repobase of
     Just rb ->
@@ -226,11 +251,11 @@ prepareRepoForPR owner repo repobase branch = do
         >>= liftIO
         .   toAbs
     Nothing -> (parseRel $ E.encodeUtf8 $ untagName repo) >>= liftIO . toAbs
-  ForkResult {..} <- withExceptT show $ forkRepository owner repo
+  ForkResult {..} <- (forkRepository owner repo) ?* (uError . show)
-  withExceptT show $ ExceptT $ cloneRepository CloneSSH downstream repodest
+  (ExceptT $ cloneRepository CloneSSH downstream repodest) ?* (uError . show)
-  withExceptT show $ ExceptT $ setUpstream upstream repodest
+  (ExceptT $ setUpstream upstream repodest) ?* (uError . show)
   case branch of
-    Just b  -> withExceptT show $ ExceptT $ createBranch b repodest
+    Just b  -> (ExceptT $ createBranch b repodest) ?* (uError . show)
     Nothing -> pure ()
   lift $ _info
     (  "To change to the repo dir, run:\n\tcd "
@@ -238,14 +263,10 @@ prepareRepoForPR owner repo repobase branch = do
     )
 
 
-forkRepository :: (MonadIO m, MonadReader Settings m)
+
-               => Name Owner
+    -------------------
-               -> Name Repo
+    --[ Git actions ]--
-               -> ExceptT Error m ForkResult
+    -------------------
-forkRepository owner repo = do
-  upstream   <- github_ (repositoryR owner repo)
-  downstream <- githubAuth (forkExistingRepoR owner repo Nothing)
-  pure $ ForkResult { .. }
 
 
 cloneRepository :: (MonadIO m, MonadFail m)
@@ -284,40 +305,111 @@ createBranch branch repodir =
   _runGit [u8 "-C", toFilePath repodir, u8 "checkout", u8 "-b", branch]
 
 
+
+
+
+    ----------------------
+    --[ 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 { .. }
+
+
 -- | Same as deleteFork, but gets the auth from the config file
 -- and parses the owner/repo from the given repo url string.
 deleteFork' :: (MonadIO m, MonadReader Settings m)
             => ByteString
-            -> ExceptT String m ()
+            -> ExceptT Error m ()
 deleteFork' repoString = do
-  UrlParseResult {..} <- liftEither $ parseURL repoString
+  UrlParseResult {..} <- (liftEither $ parseURL repoString) ?* uError
   deleteFork owner repo
 
 
 deleteFork :: (MonadIO m, MonadReader Settings m)
            => Name Owner
            -> Name Repo
-           -> ExceptT String m ()
+           -> ExceptT Error m ()
 deleteFork owner repo = do
-  (withExceptT show $ github_ (repositoryR owner repo)) >>= \case
+  github_ (repositoryR owner repo) >>= \case
     (Repo { repoFork = Just True }) -> pure ()
-    _                               -> throwError "Not a fork"
+    _                               -> throwError (uError "Not a fork")
-  withExceptT show $ githubAuth (deleteRepoR owner repo)
+  githubAuth (deleteRepoR owner repo)
-
 
 
 getForks :: (MonadIO m, MonadReader Settings m)
          => Maybe UTCTime
          -> ExceptT Error m [Repo]
 getForks mtime = do
-  repos <- githubAuth (currentUserReposR RepoPublicityAll FetchAll)
+  user <- githubAuth userInfoCurrentR
-  pure $ filter
+  let userName = untagName $ userLogin user
+  repos <- github_
+    (searchReposR $ mconcat [T.pack "user:", userName, T.pack " fork:only"])
+  pure $ sortBy (\x y -> compare (repoUpdatedAt y) (repoUpdatedAt x)) $ filter
     (\case
       Repo { repoFork = Just True, repoUpdatedAt = Just t } ->
         maybe True (t >=) mtime
       _ -> False
     )
-    (toList repos)
+    (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))
+
+
+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)
+
 
 
 
@@ -342,14 +434,20 @@ ghURLParser =
            <|> str "git@github.com:"
            <|> empty'
            )
-        *> takeWhile1 (\w -> (w /= _slash) && isAlphaNum w)
+        *> takeWhile1 (/= _slash)
         <* word8 _slash
         )
-    <*> (takeWhile1 isAlphaNum <* ((str ".git" <|> empty') <* endOfInput))
+    <*> parseRepoName
  where
   str    = string . u8
   empty' = str ""
-
+  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
 
 
 
@@ -425,3 +523,15 @@ github_ :: (MonadIO m, ParseResponse mt req, res ~ Either Error req, ro ~ 'RO)
         -> ExceptT Error m req
 github_ req = do
   ExceptT $ liftIO $ github' req
+
+
+-- | Flipped 'withExceptT'.
+(?*) :: Functor m => ExceptT e m a -> (e -> e') -> ExceptT e' m a
+(?*) = flip withExceptT
+
+
+uError :: String -> Error
+uError = UserError . T.pack
+
+$(deriveJSON defaultOptions 'GistContent)
+$(deriveJSON defaultOptions 'GistRequest)

update-index-state.sh

@@ -0,0 +1,66 @@
+#!/usr/bin/env bash
+
+set -eu
+
+status_message() {
+    printf "\\033[0;32m%s\\033[0m\\n" "$1"
+}
+
+error_message() {
+    printf "\\033[0;31m%s\\033[0m\\n" "$1"
+}
+
+SCRIPTPATH="$( cd "$(dirname "$0")" ; pwd -P )"
+CACHE_LOCATION="${HOME}/.cabal/packages/hackage.haskell.org/01-index.cache"
+
+if [ ! -f "${CACHE_LOCATION}" ] ; then
+	error_message "${CACHE_LOCATION} does not exist, did you run 'cabal update'?"
+	exit 1
+fi
+
+if [ ! -f "${SCRIPTPATH}/cabal.project" ] ; then
+	error_message "Could not find ${SCRIPTPATH}/cabal.project, skipping index state update."
+	exit 3
+fi
+
+cabal v2-update
+
+arch=$(getconf LONG_BIT)
+
+case "${arch}" in
+32)
+	byte_size=4
+	magic_word="CABA1002"
+    ;;
+64)
+	byte_size=8
+	magic_word="00000000CABA1002"
+    ;;
+*)
+	error_message "Unknown architecture (long bit): ${arch}"
+	exit 2
+    ;;
+esac
+
+# This is the logic to parse the binary format of 01-index.cache.
+# The first word is a magic 'caba1002', the second one is the timestamp in unix epoch.
+# Better than copying the cabal-install source code.
+if [ "$(xxd -u -p -l${byte_size} -s 0 "${CACHE_LOCATION}")" != "${magic_word}" ] ; then
+	error_message "Magic word does not match!"
+	exit 4
+fi
+cache_timestamp=$(echo "ibase=16;obase=A;$(xxd -u -p -l${byte_size} -s ${byte_size} "${CACHE_LOCATION}")" | bc)
+
+# If we got junk from the binary file, this should fail.
+cache_date=$(date --utc --date "@${cache_timestamp}" "+%FT%TZ")
+
+
+status_message "Updating index state in ${SCRIPTPATH}/cabal.project"
+
+if grep -q "^index-state: .*" "${SCRIPTPATH}/cabal.project" ; then
+	awk '/index-state:/ {gsub(/.*/, "index-state: '${cache_date}'")}; { print }' "${SCRIPTPATH}/cabal.project" > "${SCRIPTPATH}/cabal.project.tmp"
+	mv "${SCRIPTPATH}/cabal.project.tmp" "${SCRIPTPATH}/cabal.project"
+else
+	printf "index-state: %s\n" "${cache_date}" >> "${SCRIPTPATH}/cabal.project"
+fi
+