ghup/app/Main.hs

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



data Options = Options
  { optCommand :: Command
  }

data Command
  = Fork ForkOptions
  | Config ConfigOptions
  | Del DelOptions
  | ListForks ListForkOptions

data ForkOptions = ForkOptions
  {
    repo          :: ByteString
  , newBranch     :: Maybe ByteString
  , repoBasePath  :: Maybe ByteString
  }

data ListForkOptions = ListForkOptions
  {
    lSince        :: Maybe ByteString
  }

data ConfigOptions = ConfigOptions {
    oAuth :: ByteString
  , bPath :: Maybe ByteString
  }


data DelOptions = DelOptions {
  del :: ByteString
  }

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 "list-forks" (ListForks <$> (info (lForkOpts <**> helper) idm))
  )

configOpts :: Parser ConfigOptions
configOpts =
  ConfigOptions
    <$> strOption
          (short 'o' <> long "oauth" <> metavar "OAUTH" <> help
            "The OAUTH token"
          )
    <*> optional
          (strOption
            ((short 'p') <> long "base-path" <> metavar "BASE_PATH" <> help
              "The base path to clone into"
            )
          )

forkOpts :: Parser ForkOptions
forkOpts =
  ForkOptions
    <$> strOption
          (short 'r' <> long "repo" <> metavar "REPO" <> help
            "The repository to fork"
          )
    <*> optional
          (strOption
            (short 'b' <> long "branch" <> metavar "BRANCH" <> help
              "The branch to create after cloning the fork"
            )
          )
    <*> optional
          (strOption
            (short 'p' <> long "repo-path" <> metavar "REPO_PATH" <> help
              "The base path where to clone the repository to"
            )
          )

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 {..}) -> 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 (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
      let formatted = intercalate "\n"
            $ fmap (\Repo {..} -> T.unpack . getUrl $ repoHtmlUrl) forks
      liftIO $ putStrLn $ formatted
      pure ()
  case e of
    Right () -> pure ()
    Left  t  -> die (color Red $ t)