Add list-forks command

app/Main.hs

@@ -1,13 +1,28 @@
 module Main where
 
 import           Control.Monad
+import           Control.Monad.Except
 import           Data.ByteString                ( ByteString )
+import qualified Data.ByteString.UTF8          as UTF8
+import           Data.Dates                     ( getCurrentDateTime
+                                                , parseDate
+                                                , DateTime(..)
+                                                )
 import           Data.Functor                   ( (<&>) )
+import           Data.List
 import           Data.Semigroup                 ( (<>) )
+import qualified Data.Text                     as T
+import           Data.Time.Clock
+import           Data.Time.Clock.POSIX
+import           Data.Time.Format
 import           GHup
 import           GitHub.Auth
+import           GitHub.Data.Definitions
+import           GitHub.Data.Name
+import           GitHub.Data.Repos
 import           HPath
 import           Options.Applicative
+import           Safe
 import           System.Console.Pretty
 import           System.Exit
 
@@ -21,6 +36,7 @@ data Command
   = Fork ForkOptions
   | Config ConfigOptions
   | Del DelOptions
+  | ListForks ListForkOptions
 
 data ForkOptions = ForkOptions
   {
@@ -29,6 +45,11 @@ data ForkOptions = ForkOptions
   , repoBasePath  :: Maybe ByteString
   }
 
+data ListForkOptions = ListForkOptions
+  {
+    lSince        :: Maybe ByteString
+  }
+
 data ConfigOptions = ConfigOptions {
     oAuth :: ByteString
   , bPath :: Maybe ByteString
@@ -41,9 +62,10 @@ data DelOptions = DelOptions {
 
 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) idm))
+  <> command "config"     (Config <$> (info (configOpts <**> helper) idm))
+  <> command "delete"     (Del <$> (info (delOpts <**> helper) idm))
+  <> command "list-forks" (ListForks <$> (info (lForkOpts <**> helper) idm))
   )
 
 configOpts :: Parser ConfigOptions
@@ -84,6 +106,14 @@ 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"
+    )
+  )
+
 
 main :: IO ()
 main = do
@@ -97,7 +127,33 @@ main = do
     Config (ConfigOptions {..}) -> do
       p <- maybe (pure Nothing) (fmap Just . parseAbs) bPath
       writeSettings (Settings (OAuth oAuth) p) <&> Right
-    Del (DelOptions {..}) -> deleteFork' del
+    Del       (DelOptions {..}     ) -> deleteFork' del
+    ListForks (ListForkOptions {..}) -> runExceptT $ do
+      mtime <- lift $ 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 <- ExceptT $ getForks' mtime
+      let formatted = intercalate "\n" $ fmap
+            (\Repo {..} ->
+              T.unpack (untagName $ simpleOwnerLogin repoOwner)
+                <> "/"
+                <> T.unpack (untagName repoName)
+            )
+            forks
+      lift $ putStrLn $ formatted
+      pure ()
   case e of
     Right () -> _info "success!"
     Left  t  -> die (color Red $ t)

ghup.cabal

@@ -30,8 +30,10 @@ library
                        , safe-exceptions ^>= 0.1
                        , streamly        ^>= 0.7
                        , text            ^>= 1.2
+                       , time            ^>= 1.8
                        , unix            ^>= 2.7
                        , utf8-string     ^>= 1.0
+                       , vector          ^>= 0.12
                        , word8           ^>= 0.1
   hs-source-dirs:      lib
   ghc-options:         -Wall
@@ -44,11 +46,17 @@ executable ghup
   -- other-extensions:
   build-depends:         base                 ^>= 4.12
                        , bytestring           ^>= 0.10
+                       , dates                ^>= 0.2
                        , ghup
                        , github               ^>= 0.24
                        , hpath                ^>= 0.11
+                       , mtl                  ^>= 2.2
                        , optparse-applicative ^>= 0.15
                        , pretty-terminal      ^>= 0.1
+                       , safe                 ^>= 0.3
+                       , text                 ^>= 1.2
+                       , time                 ^>= 1.8
+                       , utf8-string          ^>= 1.0
   hs-source-dirs:      app
   default-language:    Haskell2010
   default-extensions:  LambdaCase, MultiWayIf, RecordWildCards, TupleSections

lib/GHup.hs

@@ -23,6 +23,8 @@ module GHup
   , createBranch
   , deleteFork'
   , deleteFork
+  , getForks'
+  , getForks
   -- * Parsers
   , parseURL
   , ghURLParser
@@ -43,10 +45,13 @@ import qualified Data.ByteString.Lazy.UTF8     as LUTF8
 import           Data.Functor                   ( (<&>) )
 import           Data.Proxy
 import qualified Data.Text.Encoding            as E
+import           Data.Time.Clock
 import           Data.Word8
+import           GHC.Exts                       ( toList )
 import           GitHub.Auth
 import           GitHub.Data.Name
 import           GitHub.Data.URL
+import           GitHub.Data.Request
 import           GitHub.Endpoints.Repos
 import           GitHub.Request
 import           HPath
@@ -284,6 +289,22 @@ deleteFork am owner repo = runExceptT $ do
   withExceptT show $ ExceptT $ github am (deleteRepoR owner repo)
 
 
+getForks' :: Maybe UTCTime -> IO (Either String [Repo])
+getForks' mtime = runExceptT $ do
+  Settings {..}       <- ExceptT getSettings
+  withExceptT show $ ExceptT $ getForks auth mtime
+
+
+getForks :: AuthMethod am => am -> Maybe UTCTime -> IO (Either Error [Repo])
+getForks am mtime = runExceptT $ do
+  repos <-
+      ExceptT $ github am (currentUserReposR RepoPublicityAll FetchAll)
+  pure $ filter
+        (\case
+          Repo { repoFork = Just True, repoUpdatedAt = Just t } ->
+            maybe True (t >=) mtime
+          _                             -> False
+        ) (toList repos)