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,15 +1,34 @@
 module Main where
 
-import           Control.Monad
+import           Control.Error.Util
+import           Control.Monad.Except
+import           Control.Monad.Reader
 import           Data.ByteString                ( ByteString )
+import qualified Data.ByteString.UTF8          as UTF8
+import           Data.Dates                     ( getCurrentDateTime
+                                                , parseDate
+                                                , DateTime(..)
+                                                )
 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
 import           Options.Applicative
 import           System.Console.Pretty
 import           System.Exit
+import           Text.Layout.Table
 
 
 
@@ -21,6 +40,9 @@ data Command
   = Fork ForkOptions
   | Config ConfigOptions
   | Del DelOptions
+  | ListForks ListForkOptions
+  | CreateGist CreateGistOptions
+  | ListGist ListGistOptions
 
 data ForkOptions = ForkOptions
   {
@@ -29,21 +51,85 @@ data ForkOptions = ForkOptions
   , repoBasePath  :: Maybe ByteString
   }
 
+data ListForkOptions = ListForkOptions
+  {
+    lSince        :: Maybe ByteString
+  }
+
 data ConfigOptions = ConfigOptions {
     oAuth :: ByteString
   , 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 "config" (Config <$> (info (configOpts <**> helper) idm))
-  <> command "delete" (Del <$> (info (delOpts <**> helper) idm))
+  (  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
+       "gistc"
+       (CreateGist <$> (info (cGistOpts <**> helper) (progDesc "Create gist"))
+       )
+  <> command
+       "gistl"
+       (ListGist <$> (info (lGistOpts <**> helper) (progDesc "List gists")))
   )
 
 configOpts :: Parser ConfigOptions
@@ -84,20 +170,165 @@ delOpts :: Parser DelOptions
 delOpts = DelOptions <$> strOption
   (short 'r' <> long "repo" <> metavar "REPO" <> help "The REPO fork to delete")
 
+lForkOpts :: Parser ListForkOptions
+lForkOpts = ListForkOptions <$> optional
+  (strOption
+    (short 's' <> long "since" <> metavar "SINCE" <> help
+      "The repository to fork"
+    )
+  )
+
+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
-  e <- execParser (info (opts <**> helper) idm) >>= \case
-    Fork (ForkOptions {..}) -> do
-      case repoBasePath of
-        Just rbp -> case parseAbs rbp of
-          Just p  -> prepareRepoForPR' repo (Just p) newBranch
-          Nothing -> fail "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 {..}) -> deleteFork' del
+  -- 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
+
+    -- 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
+
+            -- 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 () -> _info "success!"
+    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

@@ -0,0 +1,174 @@
+constraints: any.Cabal ==3.0.0.0,
+             Cabal -bundled-binary-generic,
+             any.IfElse ==0.85,
+             any.StateVar ==1.2,
+             any.abstract-deque ==0.3,
+             abstract-deque -usecas,
+             any.adjunctions ==4.4,
+             any.aeson ==1.4.6.0,
+             aeson -bytestring-builder -cffi -developer -fast,
+             any.ansi-terminal ==0.10.2,
+             ansi-terminal -example,
+             any.ansi-wl-pprint ==0.6.9,
+             ansi-wl-pprint -example,
+             any.array ==0.5.3.0,
+             any.asn1-encoding ==0.9.6,
+             any.asn1-parse ==0.9.5,
+             any.asn1-types ==0.3.3,
+             any.async ==2.2.2,
+             async -bench,
+             any.atomic-primops ==0.8.3,
+             atomic-primops -debug,
+             any.attoparsec ==0.13.2.3,
+             attoparsec -developer,
+             any.attoparsec-iso8601 ==1.0.1.0,
+             attoparsec-iso8601 -developer -fast,
+             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,
+             bifunctors +semigroups +tagged,
+             any.binary ==0.8.6.0,
+             any.binary-instances ==1,
+             any.binary-orphans ==1.0.1,
+             any.blaze-builder ==0.4.1.0,
+             any.bytestring ==0.10.8.2,
+             any.bytestring-conversion ==0.3.1,
+             any.cabal-doctest ==1.0.8,
+             any.case-insensitive ==1.2.1.0,
+             any.cereal ==0.5.8.1,
+             cereal -bytestring-builder,
+             any.colour ==2.3.5,
+             any.comonad ==5.0.6,
+             comonad +containers +distributive +test-doctests,
+             any.connection ==0.3.1,
+             any.containers ==0.6.0.1,
+             any.contravariant ==1.5.2,
+             contravariant +semigroups +statevar +tagged,
+             any.cookie ==0.4.5,
+             any.cryptohash-sha1 ==0.11.100.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.6.0,
+             any.distributive ==0.6.1,
+             distributive +semigroups +tagged,
+             any.dlist ==0.8.0.7,
+             any.double-conversion ==2.0.2.0,
+             double-conversion -developer,
+             any.errors ==2.3.0,
+             any.exceptions ==0.10.4,
+             exceptions +transformers-0-4,
+             any.filepath ==1.4.2.1,
+             any.free ==5.1.3,
+             any.ghc-boot-th ==8.6.5,
+             any.ghc-prim ==0.5.3,
+             any.github ==0.24,
+             github -openssl,
+             any.hashable ==1.3.0.0,
+             hashable -examples +integer-gmp +sse2 -sse41,
+             any.heaps ==0.3.6.1,
+             any.hourglass ==0.2.12,
+             any.hpath ==0.11.0,
+             any.hpath-directory ==0.13.1,
+             any.hpath-filepath ==0.10.4,
+             any.hpath-io ==0.13.1,
+             any.hpath-posix ==0.13.0,
+             any.hsc2hs ==0.68.6,
+             hsc2hs -in-ghc-tree,
+             any.http-api-data ==0.4.1.1,
+             http-api-data -use-text-show,
+             any.http-client ==0.6.4,
+             http-client +network-uri,
+             any.http-client-tls ==0.3.5.3,
+             any.http-link-header ==1.0.3.1,
+             any.http-types ==0.12.3,
+             any.integer-gmp ==1.0.2.0,
+             any.integer-logarithms ==1.0.3,
+             integer-logarithms -check-bounds +integer-gmp,
+             any.invariant ==0.5.3,
+             any.iso8601-time ==0.1.5,
+             iso8601-time +new-time,
+             any.kan-extensions ==5.2,
+             any.keys ==3.12.3,
+             any.lockfree-queue ==0.2.3.1,
+             any.memory ==0.15.0,
+             memory +support_basement +support_bytestring +support_deepseq +support_foundation,
+             any.mime-types ==0.1.0.9,
+             any.monad-control ==1.0.2.3,
+             any.mtl ==2.2.2,
+             any.network ==3.1.1.1,
+             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,
+             any.pointed ==5.0.1,
+             pointed +comonad +containers +kan-extensions +semigroupoids +semigroups +stm +tagged +transformers +unordered-containers,
+             any.pretty ==1.1.3.6,
+             any.pretty-terminal ==0.1.0.0,
+             any.primitive ==0.7.0.0,
+             any.process ==1.6.7.0,
+             any.profunctors ==5.5.1,
+             any.random ==1.1,
+             any.rts ==1.0,
+             any.safe ==0.3.18,
+             any.safe-exceptions ==0.1.7.0,
+             any.scientific ==0.3.6.2,
+             scientific -bytestring-builder -integer-simple,
+             any.semigroupoids ==5.3.4,
+             semigroupoids +comonad +containers +contravariant +distributive +doctests +tagged +unordered-containers,
+             any.semigroups ==0.19.1,
+             semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers,
+             any.socks ==0.6.1,
+             any.stm ==2.5.0.0,
+             any.streaming-commons ==0.2.1.2,
+             streaming-commons -use-bytestring-builder,
+             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.9.3,
+             any.time-compat ==1.9.2.2,
+             time-compat -old-locale,
+             any.tls ==1.5.3,
+             tls +compat -hans +network,
+             any.transformers ==0.5.6.2,
+             any.transformers-base ==0.4.5.2,
+             transformers-base +orphaninstances,
+             any.transformers-compat ==0.6.5,
+             transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
+             any.unix ==2.7.2.2,
+             any.unix-bytestring ==0.3.7.3,
+             any.unordered-containers ==0.2.10.0,
+             unordered-containers -debug,
+             any.utf8-string ==1.0.1.1,
+             any.uuid-types ==1.0.3,
+             any.vector ==0.12.0.3,
+             vector +boundschecks -internalchecks -unsafechecks -wall,
+             any.vector-binary-instances ==0.2.5.1,
+             any.vector-instances ==3.4,
+             vector-instances +hashable,
+             any.void ==0.7.3,
+             void -safe,
+             any.word8 ==0.1.3,
+             any.x509 ==1.7.5,
+             any.x509-store ==1.6.7,
+             any.x509-system ==1.6.6,
+             any.x509-validation ==1.6.11,
+             any.zlib ==0.6.2.1,
+             zlib -non-blocking-ffi -pkg-config

ghup.cabal

@@ -18,21 +18,25 @@ library
   exposed-modules:     GHup
   -- other-modules:
   -- other-extensions:
-  build-depends:         attoparsec      ^>= 0.13
-                       , base            ^>= 4.12
-                       , bytestring      ^>= 0.10
-                       , github          ^>= 0.24
-                       , hpath           ^>= 0.11
-                       , hpath-io        ^>= 0.13.1
-                       , http-client     ^>= 0.6.4
-                       , mtl             ^>= 2.2
-                       , pretty-terminal ^>= 0.1
-                       , safe-exceptions ^>= 0.1
-                       , streamly        ^>= 0.7
-                       , text            ^>= 1.2
-                       , unix            ^>= 2.7
-                       , utf8-string     ^>= 1.0
-                       , word8           ^>= 0.1
+  build-depends:         aeson                ^>= 1.4
+                       , attoparsec           ^>= 0.13
+                       , base                 ^>= 4.12
+                       , bytestring           ^>= 0.10
+                       , github               ^>= 0.24
+                       , hpath                ^>= 0.11
+                       , hpath-io             ^>= 0.13.1
+                       , http-client          ^>= 0.6.4
+                       , mtl                  ^>= 2.2
+                       , pretty-terminal      ^>= 0.1
+                       , safe-exceptions      ^>= 0.1
+                       , streamly             ^>= 0.7
+                       , text                 ^>= 1.2
+                       , time                 ^>= 1.9
+                       , unix                 ^>= 2.7
+                       , unordered-containers ^>= 0.2
+                       , utf8-string          ^>= 1.0
+                       , vector               ^>= 0.12
+                       , word8                ^>= 0.1
   hs-source-dirs:      lib
   ghc-options:         -Wall
   default-language:    Haskell2010
@@ -44,12 +48,20 @@ executable ghup
   -- other-extensions:
   build-depends:         base                 ^>= 4.12
                        , bytestring           ^>= 0.10
+                       , dates                ^>= 0.2
+                       , errors               ^>= 2.3
                        , ghup
                        , github               ^>= 0.24
                        , hpath                ^>= 0.11
+                       , mtl                  ^>= 2.2
                        , optparse-applicative ^>= 0.15
                        , pretty-terminal      ^>= 0.1
+                       , table-layout         ^>= 0.8
+                       , text                 ^>= 1.2
+                       , 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,13 +1,19 @@
-{-# LANGUAGE DeriveGeneric      #-}
-{-# LANGUAGE FlexibleInstances  #-}
-{-# LANGUAGE QuasiQuotes        #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# OPTIONS_GHC -Wno-orphans    #-}
+{-# LANGUAGE DataKinds                 #-}
+{-# 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(..)
@@ -23,6 +29,11 @@ module GHup
   , createBranch
   , deleteFork'
   , deleteFork
+  , getForks
+  , postGistStdin
+  , postGistFiles
+  , postGist
+  , listGists
   -- * Parsers
   , parseURL
   , ghURLParser
@@ -30,29 +41,51 @@ module GHup
   , _info
   , _warn
   , _err
+  , uError
   )
 where
 
 import           Control.Applicative
 import           Control.Exception.Safe
-import           Control.Monad.Except
+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
 import           Prelude                 hiding ( readFile
                                                 , writeFile
+                                                , fail
                                                 )
 import           System.Console.Pretty
 import           System.IO                      ( hPutStrLn
@@ -98,8 +131,8 @@ data UrlParseResult = UrlParseResult {
 
 
 data Settings = Settings {
-    auth     :: Auth
-  , basePath :: Maybe (Path Abs)
+    _auth     :: Auth
+  , _basePath :: Maybe (Path Abs)
 } deriving (Eq, Read, Show)
 
 
@@ -115,6 +148,8 @@ instance Read (Path Abs) where
           _ -> []
 
 
+data AnyPath = forall a . AnyPath (Path a)
+
 
 
 
@@ -124,7 +159,7 @@ instance Read (Path Abs) where
 
 
 
-writeSettings :: Settings -> IO ()
+writeSettings :: (MonadThrow m, MonadIO m) => Settings -> m ()
 writeSettings settings = do
   sf <- getSettingsFile
   let fileperms =
@@ -132,86 +167,95 @@ writeSettings settings = do
           `unionFileModes` ownerReadMode
           `unionFileModes` groupWriteMode
           `unionFileModes` groupReadMode
-  writeFile sf (Just fileperms) (u8 . show $ settings)
+  liftIO $ writeFile sf (Just fileperms) (u8 . show $ settings)
   _info ("Written config to file " <> (UTF8.toString $ toFilePath sf))
 
 
-getSettingsFile :: IO (Path Abs)
+getSettingsFile :: (MonadThrow m, MonadIO m) => m (Path Abs)
 getSettingsFile = do
   let app_dir = [rel|ghup|] :: Path Rel
-  getEnv (u8 "XDG_CONFIG_HOME") >>= \case
+  (liftIO $ getEnv (u8 "XDG_CONFIG_HOME")) >>= \case
     Just config -> do
       pc <- parseAbs config
       pure $ pc </> app_dir
     Nothing -> do
       let config_dir = [rel|.config|] :: Path Rel
-      home <- getHomeDirectory >>= parseAbs
+      home <- liftIO (getHomeDirectory >>= parseAbs)
       pure $ home </> config_dir </> app_dir
 
 
-getSettings :: IO (Either String Settings)
-getSettings = runExceptT (fromEnv <|> fromFile)
+getSettings :: (MonadThrow m, MonadIO m) => ExceptT String m Settings
+getSettings = (fromEnv <|> fromFile)
 
  where
-  fromEnv :: ExceptT String IO Settings
+  fromEnv :: MonadIO m => ExceptT String m Settings
   fromEnv = do
-    (lift $ getEnv (u8 "GITHUB_TOKEN")) >>= \case
+    (liftIO $ getEnv (u8 "GITHUB_TOKEN")) >>= \case
       Just t  -> pure $ Settings (OAuth t) Nothing
       Nothing -> throwError "Not found"
-  fromFile :: ExceptT String IO Settings
+  fromFile :: (MonadThrow m, MonadIO m) => ExceptT String m Settings
   fromFile = do
-    sf  <- lift $ getSettingsFile
+    sf  <- getSettingsFile
     out <-
       ExceptT
-        $ ( flip catchIOError (\e -> pure $ Left $ show e)
-          $ fmap Right
-          $ readFile sf
-          )
+      $ liftIO
+      $ (flip catchIOError (\e -> pure $ Left $ show e) $ fmap Right $ readFile
+          sf
+        )
     liftEither $ readEither (LUTF8.toString out)
 
 
 
 
-    ----------------------------
-    --[ Github / Git actions ]--
-    ----------------------------
+    -------------------------------------
+    --[ Combined Github / Git actions ]--
+    -------------------------------------
 
 
 -- | Same as 'prepareRepoForPR', but gets the auth from the config file
 -- and parses the owner/repo from the given repo url string.
-prepareRepoForPR' :: ByteString       -- ^ string that contains repo url
+prepareRepoForPR' :: ( MonadIO m
+                     , MonadReader Settings m
+                     , MonadFail m
+                     , MonadThrow 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
-                  -> IO (Either String ())
-prepareRepoForPR' repoString mRepobase branch = runExceptT $ do
-  UrlParseResult {..} <- liftEither $ parseURL repoString
-  Settings {..}       <- ExceptT getSettings
+                  -> ExceptT Error m ()
+prepareRepoForPR' repoString mRepobase branch = do
+  UrlParseResult {..} <- (liftEither $ parseURL repoString) ?* uError
   repobase            <- case mRepobase of
-    Just r  -> fmap Just $ lift $ toAbs r
-    Nothing -> pure basePath
-  ExceptT $ prepareRepoForPR auth owner repo repobase branch
+    Just r  -> fmap Just $ liftIO $ toAbs r
+    Nothing -> basePath
+  prepareRepoForPR owner repo repobase branch
 
 
 
 -- | Fork the repository to my account, clone it, add original upstream
 -- as remote, optionally switch to the given branch.
-prepareRepoForPR :: AuthMethod am
-                 => am
-                 -> Name Owner
+prepareRepoForPR :: ( MonadIO m
+                    , MonadReader Settings m
+                    , MonadFail m
+                    , MonadThrow m
+                    )
+                 => Name Owner
                  -> Name Repo
                  -> Maybe (Path b)   -- ^ base path where the repo should be cloned
                  -> Maybe ByteString -- ^ PR branch name to switch to
-                 -> IO (Either String ())
-prepareRepoForPR am owner repo repobase branch = runExceptT $ do
+                 -> ExceptT Error m ()
+prepareRepoForPR owner repo repobase branch = do
   repodest <- case repobase of
     Just rb ->
-      ((rb </>) <$> (parseRel $ E.encodeUtf8 $ untagName repo)) >>= lift . toAbs
-    Nothing -> (parseRel $ E.encodeUtf8 $ untagName repo) >>= lift . toAbs
-  ForkResult {..} <- withExceptT show $ ExceptT $ forkRepository am owner repo
-  withExceptT show $ ExceptT $ cloneRepository CloneSSH downstream repodest
-  withExceptT show $ ExceptT $ setUpstream upstream repodest
+      ((rb </>) <$> (parseRel $ E.encodeUtf8 $ untagName repo))
+        >>= liftIO
+        .   toAbs
+    Nothing -> (parseRel $ E.encodeUtf8 $ untagName repo) >>= liftIO . toAbs
+  ForkResult {..} <- (forkRepository owner repo) ?* (uError . show)
+  (ExceptT $ cloneRepository CloneSSH downstream repodest) ?* (uError . show)
+  (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 "
@@ -219,21 +263,17 @@ prepareRepoForPR am owner repo repobase branch = runExceptT $ do
     )
 
 
-forkRepository :: AuthMethod am
-               => am
-               -> Name Owner
-               -> Name Repo
-               -> IO (Either Error ForkResult)
-forkRepository am owner repo = runExceptT $ do
-  upstream   <- ExceptT $ github' (repositoryR owner repo)
-  downstream <- ExceptT $ github am (forkExistingRepoR owner repo Nothing)
-  pure $ ForkResult { .. }
+
+    -------------------
+    --[ Git actions ]--
+    -------------------
 
 
-cloneRepository :: CloneMethod
+cloneRepository :: (MonadIO m, MonadFail m)
+                => CloneMethod
                 -> Repo
                 -> Path b  -- ^ full path where the repo should be cloned to
-                -> IO (Either ProcessError ())
+                -> m (Either ProcessError ())
 cloneRepository CloneSSH (Repo { repoSshUrl = (Just url) }) dest =
   _clone (E.encodeUtf8 $ getUrl url) (toFilePath dest)
 cloneRepository CloneHTTP (Repo { repoCloneUrl = (Just url) }) dest =
@@ -242,9 +282,10 @@ cloneRepository _ _ _ = fail "No clone url!"
 
 
 
-setUpstream :: Repo   -- ^ upstream
+setUpstream :: (MonadIO m, MonadFail m)
+            => Repo   -- ^ upstream
             -> Path b -- ^ full path to repo
-            -> IO (Either ProcessError ())
+            -> m (Either ProcessError ())
 setUpstream (Repo { repoCloneUrl = (Just url) }) repodir = _runGit
   [ u8 "-C"
   , toFilePath repodir
@@ -256,34 +297,119 @@ setUpstream (Repo { repoCloneUrl = (Just url) }) repodir = _runGit
 setUpstream _ _ = fail "No clone url!"
 
 
-createBranch :: ByteString  -- ^ branch name
+createBranch :: MonadIO m
+             => ByteString  -- ^ branch name
              -> Path b      -- ^ full path to repo
-             -> IO (Either ProcessError ())
+             -> m (Either ProcessError ())
 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' :: ByteString -> IO (Either String ())
-deleteFork' repoString = runExceptT $ do
-  UrlParseResult {..} <- liftEither $ parseURL repoString
-  Settings {..}       <- ExceptT getSettings
-  ExceptT $ deleteFork auth owner repo
+deleteFork' :: (MonadIO m, MonadReader Settings m)
+            => ByteString
+            -> ExceptT Error m ()
+deleteFork' repoString = do
+  UrlParseResult {..} <- (liftEither $ parseURL repoString) ?* uError
+  deleteFork owner repo
 
 
-deleteFork :: AuthMethod am
-           => am
-           -> Name Owner
+deleteFork :: (MonadIO m, MonadReader Settings m)
+           => Name Owner
            -> Name Repo
-           -> IO (Either String ())
-deleteFork am owner repo = runExceptT $ do
-  (withExceptT show $ ExceptT $ github' (repositoryR owner repo)) >>= \case
+           -> ExceptT Error m ()
+deleteFork owner repo = do
+  github_ (repositoryR owner repo) >>= \case
     (Repo { repoFork = Just True }) -> pure ()
-    _                               -> throwError "Not a fork"
-  withExceptT show $ ExceptT $ github am (deleteRepoR owner repo)
+    _                               -> throwError (uError "Not a fork")
+  githubAuth (deleteRepoR owner repo)
 
 
+getForks :: (MonadIO m, MonadReader Settings m)
+         => Maybe UTCTime
+         -> ExceptT Error m [Repo]
+getForks mtime = do
+  user <- githubAuth userInfoCurrentR
+  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 $ 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)
+
 
 
 
@@ -308,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
 
 
 
@@ -327,7 +459,7 @@ ghURLParser =
 u8 :: String -> ByteString
 u8 = UTF8.fromString
 
-_clone :: ByteString -> ByteString -> IO (Either ProcessError ())
+_clone :: MonadIO m => ByteString -> ByteString -> m (Either ProcessError ())
 _clone url dest = _runGit [u8 "clone", url, dest]
 
 _toGitError :: Maybe ProcessStatus -> Either ProcessError ()
@@ -338,8 +470,8 @@ _toGitError ps = case ps of
   Just (SPPB.Stopped _             ) -> Left $ ProcessInterrupted
   Nothing                            -> Left $ NoSuchPid
 
-_runGit :: [ByteString] -> IO (Either ProcessError ())
-_runGit args = do
+_runGit :: MonadIO m => [ByteString] -> m (Either ProcessError ())
+_runGit args = liftIO $ do
   pid <- executeFile ([rel|git|] :: Path Rel) args
   SPPB.getProcessStatus True True pid <&> _toGitError
 
@@ -354,14 +486,52 @@ getHomeDirectory = do
       pure $ u8 h -- this is a guess
 
 
-_info :: String -> IO ()
-_info = putStrLn . color Green
+_info :: MonadIO m => String -> m ()
+_info = liftIO . _stderr . color Green
 
-_warn :: String -> IO ()
-_warn = _stderr . color Yellow
+_warn :: MonadIO m => String -> m ()
+_warn = liftIO . _stderr . color Yellow
 
-_err :: String -> IO ()
-_err = _stderr . color Red
+_err :: MonadIO m => String -> m ()
+_err = liftIO . _stderr . color Red
 
-_stderr :: String -> IO ()
-_stderr = hPutStrLn stderr
+_stderr :: MonadIO m => String -> m ()
+_stderr = liftIO . hPutStrLn stderr
+
+
+auth :: MonadReader Settings m => m Auth
+auth = asks _auth
+
+basePath :: MonadReader Settings m => m (Maybe (Path Abs))
+basePath = asks _basePath
+
+
+githubAuth :: ( MonadReader Settings m
+              , MonadIO m
+              , ParseResponse mt req
+              , res ~ Either Error req
+              )
+           => (GenRequest mt rw req)
+           -> ExceptT Error m req
+githubAuth req = do
+  a <- auth
+  ExceptT $ liftIO $ github a req
+
+
+github_ :: (MonadIO m, ParseResponse mt req, res ~ Either Error req, ro ~ 'RO)
+        => (GenRequest mt ro req)
+        -> 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
+