Refactor

app/Main.hs

@@ -1,13 +1,31 @@
 module Main where
 
+import           Control.Error.Util
 import           Control.Monad
+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.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           GitHub.Data.URL
 import           HPath
 import           Options.Applicative
+import           Safe
 import           System.Console.Pretty
 import           System.Exit
 
@@ -21,6 +39,7 @@ data Command
   = Fork ForkOptions
   | Config ConfigOptions
   | Del DelOptions
+  | ListForks ListForkOptions
 
 data ForkOptions = ForkOptions
   {
@@ -29,6 +48,11 @@ data ForkOptions = ForkOptions
   , repoBasePath  :: Maybe ByteString
   }
 
+data ListForkOptions = ListForkOptions
+  {
+    lSince        :: Maybe ByteString
+  }
+
 data ConfigOptions = ConfigOptions {
     oAuth :: ByteString
   , bPath :: Maybe ByteString
@@ -41,9 +65,10 @@ data DelOptions = DelOptions {
 
 opts :: Parser Command
 opts = subparser
-  (  command "fork"   (Fork <$> (info (forkOpts <**> helper) idm))
+  (  command "fork"       (Fork <$> (info (forkOpts <**> helper) idm))
-  <> command "config" (Config <$> (info (configOpts <**> helper) idm))
+  <> command "config"     (Config <$> (info (configOpts <**> helper) idm))
-  <> command "delete" (Del <$> (info (delOpts <**> helper) idm))
+  <> command "delete"     (Del <$> (info (delOpts <**> helper) idm))
+  <> command "list-forks" (ListForks <$> (info (lForkOpts <**> helper) idm))
   )
 
 configOpts :: Parser ConfigOptions
@@ -84,20 +109,60 @@ 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
+  let
+    run e = do
+      settings <-
+        exceptT
+            ( const die
+            . 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
-    Fork (ForkOptions {..}) -> do
+    Fork (ForkOptions {..}) -> run $ 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 -> 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 {..}) -> deleteFork' del
+    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
+      let formatted = intercalate "\n"
+            $ fmap (\Repo {..} -> T.unpack . getUrl $ repoHtmlUrl) forks
+      liftIO $ putStrLn $ formatted
+      pure ()
   case e of
-    Right () -> _info "success!"
+    Right () -> pure ()
     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,18 @@ 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
+                       , 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

@@ -1,7 +1,10 @@
+{-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE FlexibleContexts   #-}
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE QuasiQuotes        #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies       #-}
 {-# OPTIONS_GHC -Wno-orphans    #-}
 
 module GHup
@@ -23,6 +26,7 @@ module GHup
   , createBranch
   , deleteFork'
   , deleteFork
+  , getForks
   -- * Parsers
   , parseURL
   , ghURLParser
@@ -35,7 +39,9 @@ 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.Attoparsec.ByteString
 import           Data.ByteString                ( ByteString )
 import qualified Data.ByteString.UTF8          as UTF8
@@ -43,16 +49,20 @@ 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
 import           HPath.IO
 import           Prelude                 hiding ( readFile
                                                 , writeFile
+                                                , fail
                                                 )
 import           System.Console.Pretty
 import           System.IO                      ( hPutStrLn
@@ -98,8 +108,8 @@ data UrlParseResult = UrlParseResult {
 
 
 data Settings = Settings {
-    auth     :: Auth
+    _auth     :: Auth
-  , basePath :: Maybe (Path Abs)
+  , _basePath :: Maybe (Path Abs)
 } deriving (Eq, Read, Show)
 
 
@@ -124,7 +134,7 @@ instance Read (Path Abs) where
 
 
 
-writeSettings :: Settings -> IO ()
+writeSettings :: (MonadThrow m, MonadIO m) => Settings -> m ()
 writeSettings settings = do
   sf <- getSettingsFile
   let fileperms =
@@ -132,41 +142,41 @@ 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 :: (MonadThrow m, MonadIO m) => ExceptT String m Settings
-getSettings = runExceptT (fromEnv <|> fromFile)
+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)
+      $ liftIO
-          $ fmap Right
+      $ (flip catchIOError (\e -> pure $ Left $ show e) $ fmap Right $ readFile
-          $ readFile sf
+          sf
-          )
+        )
     liftEither $ readEither (LUTF8.toString out)
 
 
@@ -179,35 +189,44 @@ getSettings = runExceptT (fromEnv <|> fromFile)
 
 -- | 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 ())
+                  -> ExceptT String m ()
-prepareRepoForPR' repoString mRepobase branch = runExceptT $ do
+prepareRepoForPR' repoString mRepobase branch = do
   UrlParseResult {..} <- liftEither $ parseURL repoString
-  Settings {..}       <- ExceptT getSettings
   repobase            <- case mRepobase of
-    Just r  -> fmap Just $ lift $ toAbs r
+    Just r  -> fmap Just $ liftIO $ toAbs r
-    Nothing -> pure basePath
+    Nothing -> basePath
-  ExceptT $ prepareRepoForPR auth owner repo repobase branch
+  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
+prepareRepoForPR :: ( MonadIO m
-                 => am
+                    , MonadReader Settings m
-                 -> Name Owner
+                    , 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 ())
+                 -> ExceptT String m ()
-prepareRepoForPR am owner repo repobase branch = runExceptT $ do
+prepareRepoForPR owner repo repobase branch = do
   repodest <- case repobase of
     Just rb ->
-      ((rb </>) <$> (parseRel $ E.encodeUtf8 $ untagName repo)) >>= lift . toAbs
+      ((rb </>) <$> (parseRel $ E.encodeUtf8 $ untagName repo))
-    Nothing -> (parseRel $ E.encodeUtf8 $ untagName repo) >>= lift . toAbs
+        >>= liftIO
-  ForkResult {..} <- withExceptT show $ ExceptT $ forkRepository am owner repo
+        .   toAbs
+    Nothing -> (parseRel $ E.encodeUtf8 $ untagName repo) >>= liftIO . toAbs
+  ForkResult {..} <- withExceptT show $ forkRepository owner repo
   withExceptT show $ ExceptT $ cloneRepository CloneSSH downstream repodest
   withExceptT show $ ExceptT $ setUpstream upstream repodest
   case branch of
@@ -219,21 +238,21 @@ prepareRepoForPR am owner repo repobase branch = runExceptT $ do
     )
 
 
-forkRepository :: AuthMethod am
+forkRepository :: (MonadIO m, MonadReader Settings m)
-               => am
+               => Name Owner
-               -> Name Owner
                -> Name Repo
-               -> IO (Either Error ForkResult)
+               -> ExceptT Error m ForkResult
-forkRepository am owner repo = runExceptT $ do
+forkRepository owner repo = do
-  upstream   <- ExceptT $ github' (repositoryR owner repo)
+  upstream   <- github_ (repositoryR owner repo)
-  downstream <- ExceptT $ github am (forkExistingRepoR owner repo Nothing)
+  downstream <- githubAuth (forkExistingRepoR owner repo Nothing)
   pure $ ForkResult { .. }
 
 
-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 +261,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,35 +276,49 @@ 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]
 
 
 -- | 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' :: (MonadIO m, MonadReader Settings m)
-deleteFork' repoString = runExceptT $ do
+            => ByteString
+            -> ExceptT String m ()
+deleteFork' repoString = do
   UrlParseResult {..} <- liftEither $ parseURL repoString
-  Settings {..}       <- ExceptT getSettings
+  deleteFork owner repo
-  ExceptT $ deleteFork auth owner repo
 
 
-deleteFork :: AuthMethod am
+deleteFork :: (MonadIO m, MonadReader Settings m)
-           => am
+           => Name Owner
-           -> Name Owner
            -> Name Repo
-           -> IO (Either String ())
+           -> ExceptT String m ()
-deleteFork am owner repo = runExceptT $ do
+deleteFork owner repo = do
-  (withExceptT show $ ExceptT $ github' (repositoryR owner repo)) >>= \case
+  (withExceptT show $ github_ (repositoryR owner repo)) >>= \case
     (Repo { repoFork = Just True }) -> pure ()
     _                               -> throwError "Not a fork"
-  withExceptT show $ ExceptT $ github am (deleteRepoR owner repo)
+  withExceptT show $ githubAuth (deleteRepoR owner repo)
 
 
 
+getForks :: (MonadIO m, MonadReader Settings m)
+         => Maybe UTCTime
+         -> ExceptT Error m [Repo]
+getForks mtime = do
+  repos <- githubAuth (currentUserReposR RepoPublicityAll FetchAll)
+  pure $ filter
+    (\case
+      Repo { repoFork = Just True, repoUpdatedAt = Just t } ->
+        maybe True (t >=) mtime
+      _ -> False
+    )
+    (toList repos)
+
 
 
     ---------------
@@ -327,7 +361,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 +372,8 @@ _toGitError ps = case ps of
   Just (SPPB.Stopped _             ) -> Left $ ProcessInterrupted
   Nothing                            -> Left $ NoSuchPid
 
-_runGit :: [ByteString] -> IO (Either ProcessError ())
+_runGit :: MonadIO m => [ByteString] -> m (Either ProcessError ())
-_runGit args = do
+_runGit args = liftIO $ do
   pid <- executeFile ([rel|git|] :: Path Rel) args
   SPPB.getProcessStatus True True pid <&> _toGitError
 
@@ -354,14 +388,40 @@ getHomeDirectory = do
       pure $ u8 h -- this is a guess
 
 
-_info :: String -> IO ()
+_info :: MonadIO m => String -> m ()
-_info = putStrLn . color Green
+_info = liftIO . _stderr . color Green
 
-_warn :: String -> IO ()
+_warn :: MonadIO m => String -> m ()
-_warn = _stderr . color Yellow
+_warn = liftIO . _stderr . color Yellow
 
-_err :: String -> IO ()
+_err :: MonadIO m => String -> m ()
-_err = _stderr . color Red
+_err = liftIO . _stderr . color Red
 
-_stderr :: String -> IO ()
+_stderr :: MonadIO m => String -> m ()
-_stderr = hPutStrLn stderr
+_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