From 535f48bcbcb40c8b4d5c54092380e8db419d04f8 Mon Sep 17 00:00:00 2001 From: Dmitrii Kovanikov Date: Mon, 5 Apr 2021 14:51:30 +0100 Subject: [PATCH] [#214] Initial rewrite to GraphQL --- cabal.project | 6 + hit-on.cabal | 31 +++-- src/Hit/Cli.hs | 5 +- src/Hit/Core.hs | 13 +- src/Hit/Error.hs | 26 ++++ src/Hit/Formatting.hs | 7 + src/Hit/Git.hs | 5 +- src/Hit/Git/Clone.hs | 1 + src/Hit/Git/Common.hs | 11 +- src/Hit/{ => Git}/Issue.hs | 239 +++++++++++++++-------------------- src/Hit/GitHub.hs | 111 +--------------- src/Hit/GitHub/Auth.hs | 99 +++++++++++++++ src/Hit/GitHub/Issue.hs | 211 +++++++++++++++++++++++++++++++ src/Hit/GitHub/Milestone.hs | 74 +++++++++++ src/Hit/GitHub/Repository.hs | 45 +++++++ 15 files changed, 627 insertions(+), 257 deletions(-) create mode 100644 cabal.project create mode 100644 src/Hit/Error.hs rename src/Hit/{ => Git}/Issue.hs (66%) create mode 100644 src/Hit/GitHub/Auth.hs create mode 100644 src/Hit/GitHub/Issue.hs create mode 100644 src/Hit/GitHub/Milestone.hs create mode 100644 src/Hit/GitHub/Repository.hs diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..9a1663c --- /dev/null +++ b/cabal.project @@ -0,0 +1,6 @@ +packages: . + +source-repository-package + type: git + location: https://github.com/kowainik/github-grapqhl.git + tag: 5ffa6fc31631bc0e2f9b5b071e340cb49002c009 \ No newline at end of file diff --git a/hit-on.cabal b/hit-on.cabal index 32e8e87..238d4ef 100644 --- a/hit-on.cabal +++ b/hit-on.cabal @@ -9,36 +9,42 @@ license: MPL-2.0 license-file: LICENSE author: Veronika Romashkina, Dmitrii Kovanikov maintainer: Kowainik -copyright: 2019-2020 Kowainik +copyright: 2019-2021 Kowainik category: Git, CLI Tool build-type: Simple extra-doc-files: README.md CHANGELOG.md tested-with: GHC == 8.8.4 + GHC == 8.10.4 source-repository head type: git location: https://github.com/kowainik/hit-on.git common common-options - build-depends: base ^>= 4.13.0.0 + build-depends: base >= 4.13.0.0 && < 4.15 , relude ^>= 0.7.0.0 mixins: base hiding (Prelude) , relude (Relude as Prelude) ghc-options: -Wall - -Wincomplete-uni-patterns - -Wincomplete-record-updates -Wcompat -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints + -Wnoncanonical-monad-instances -fhide-source-paths -Wmissing-export-lists -Wpartial-fields - if impl(ghc >= 8.8.1) + if impl(ghc >= 8.8) ghc-options: -Wmissing-deriving-strategies -Werror=missing-deriving-strategies + -fwrite-ide-info + -hiedir=.hie + if impl(ghc >= 8.10) + ghc-options: -Wunused-packages default-language: Haskell2010 default-extensions: ConstraintKinds @@ -52,6 +58,7 @@ common common-options RecordWildCards ScopedTypeVariables StandaloneDeriving + StrictData TupleSections TypeApplications ViewPatterns @@ -62,6 +69,7 @@ library exposed-modules: Hit Hit.Cli Hit.Core + Hit.Error Hit.Formatting Hit.Git Hit.Git.Amend @@ -75,6 +83,7 @@ library Hit.Git.Fix Hit.Git.Fresh Hit.Git.Hop + Hit.Git.Issue Hit.Git.Log Hit.Git.Milestones Hit.Git.Pr @@ -87,23 +96,27 @@ library Hit.Git.Uncommit Hit.Git.Wip Hit.GitHub + Hit.GitHub.Auth + Hit.GitHub.Issue + Hit.GitHub.Milestone + Hit.GitHub.Repository Hit.Hub Hit.Prompt - Hit.Issue autogen-modules: Paths_hit_on other-modules: Paths_hit_on - build-depends: ansi-terminal >= 0.8 + build-depends: aeson ^>= 1.5 + , ansi-terminal >= 0.8 , colourista ^>= 0.1 , directory ^>= 1.3 - , github ^>= 0.23 + , github-graphql ^>= 0.0 , gitrev ^>= 1.3 , optparse-applicative ^>= 0.15 , process ^>= 1.6 + , prolens ^>= 0.0 , shellmet ^>= 0.0.3.0 , text - , vector ^>= 0.12 executable hit import: common-options diff --git a/src/Hit/Cli.hs b/src/Hit/Cli.hs index c40cf58..a4ca03d 100644 --- a/src/Hit/Cli.hs +++ b/src/Hit/Cli.hs @@ -27,10 +27,9 @@ import Options.Applicative (CommandFields, Mod, Parser, ParserInfo, argument, au import Hit.Core (CommitOptions (..), ForceFlag (..), IssueOptions (..), Milestone (..), NewOptions (..), TagAction (..), TagOptions (..), defaultIssueOptions) import Hit.Git (runAmend, runClear, runClone, runCommit, runCurrent, runDiff, runFix, runFork, - runFresh, runHop, runLog, runMilestones, runNew, runPr, runPush, runRename, - runResolve, runStatus, runSync, runTag, runUncommit, runWip) + runFresh, runHop, runIssue, runLog, runMilestones, runNew, runPr, runPush, + runRename, runResolve, runStatus, runSync, runTag, runUncommit, runWip) import Hit.Git.Stash (runStash, runStashClear, runStashDiff, runStashList, runUnstash) -import Hit.Issue (runIssue) import Hit.Prompt (arrow) import qualified Data.Text as T diff --git a/src/Hit/Core.hs b/src/Hit/Core.hs index 5067c63..49f4691 100644 --- a/src/Hit/Core.hs +++ b/src/Hit/Core.hs @@ -10,7 +10,11 @@ This module contains core data types used in the package. -} module Hit.Core - ( ForceFlag (..) + ( -- * Wrapper types + Owner (..) + , Repo (..) + + , ForceFlag (..) , CommitOptions (..) -- * @hit issue@ , IssueOptions (..) @@ -25,6 +29,13 @@ module Hit.Core , TagAction (..) ) where +newtype Owner = Owner + { unOwner :: Text + } + +newtype Repo = Repo + { unRepo :: Text + } {- | Data type to represent the type of @push@ or @sync@: force-push (force-reset) or not. diff --git a/src/Hit/Error.hs b/src/Hit/Error.hs new file mode 100644 index 0000000..9d9325d --- /dev/null +++ b/src/Hit/Error.hs @@ -0,0 +1,26 @@ +{- | +Module : Hit.Error +Copyright : (c) 2021 Kowainik +SPDX-License-Identifier : MPL-2.0 +Maintainer : Kowainik +Stability : Stable +Portability : Portable + +Custom errors of the @hit@ tool. +-} + +module Hit.Error + ( HitError (..) + , renderHitError + ) where + +data HitError + = NoGitHubTokenEnv + | InvalidOwnerRepo + +renderHitError :: HitError -> Text +renderHitError = \case + NoGitHubTokenEnv -> + "The environment variable GITHUB_TOKEN is not set" + InvalidOwnerRepo -> + "Cannot not parse the 'owner' and 'repo' names from the owner/repo format" diff --git a/src/Hit/Formatting.hs b/src/Hit/Formatting.hs index 390fc81..2793264 100644 --- a/src/Hit/Formatting.hs +++ b/src/Hit/Formatting.hs @@ -12,6 +12,7 @@ Common functions to format output in a certain way, module Hit.Formatting ( maxLenOn , stripRfc + , spaces ) where import qualified Data.Text as T @@ -31,3 +32,9 @@ maxLenOn f = foldl' (\acc a -> max acc $ T.length $ f a) 0 -} stripRfc :: Text -> Text stripRfc x = fromMaybe x $ T.stripPrefix "[RFC] " x + +{- | Generate @n@ spaces (useful for padding). +-} +spaces :: Int -> Text +spaces 0 = "" +spaces n = stimes n " " diff --git a/src/Hit/Git.hs b/src/Hit/Git.hs index 5b75252..a9accca 100644 --- a/src/Hit/Git.hs +++ b/src/Hit/Git.hs @@ -34,8 +34,7 @@ module Hit.Git , runLog , runMilestones , runTag - - , getUsername + , runIssue ) where import Hit.Git.Amend (runAmend) @@ -43,12 +42,12 @@ import Hit.Git.Branch (runNew, runRename) import Hit.Git.Clear (runClear) import Hit.Git.Clone (runClone, runFork) import Hit.Git.Commit (runCommit) -import Hit.Git.Common (getUsername) import Hit.Git.Current (runCurrent) import Hit.Git.Diff (runDiff) import Hit.Git.Fix (runFix) import Hit.Git.Fresh (runFresh) import Hit.Git.Hop (runHop) +import Hit.Git.Issue (runIssue) import Hit.Git.Log (runLog) import Hit.Git.Milestones (runMilestones) import Hit.Git.Pr (runPr) diff --git a/src/Hit/Git/Clone.hs b/src/Hit/Git/Clone.hs index f044cf5..85d91c4 100644 --- a/src/Hit/Git/Clone.hs +++ b/src/Hit/Git/Clone.hs @@ -47,6 +47,7 @@ runClone txt = do {- | -} +-- TODO: rewrite to 'hub' runFork :: Text -> IO () runFork name = getGitHubToken >>= \case Nothing -> errorMessage "Can not get GITHUB_TOKEN" >> exitFailure diff --git a/src/Hit/Git/Common.hs b/src/Hit/Git/Common.hs index c48171d..abc32b5 100644 --- a/src/Hit/Git/Common.hs +++ b/src/Hit/Git/Common.hs @@ -12,6 +12,7 @@ Helper functions used by different Hit Commands. module Hit.Git.Common ( branchOrMain , getUsername + , meToUsername , getMainBranch , getCurrentBranch , whenOnMainBranch @@ -32,7 +33,15 @@ import qualified Data.Text as T branchOrMain :: Maybe Text -> IO Text branchOrMain = \case Just branch -> pure branch - Nothing -> getMainBranch + Nothing -> getMainBranch + +{- | If requested, get the username. +-} +meToUsername :: Bool -> IO (Maybe Text) +meToUsername isMe = + if isMe + then Just <$> getUsername + else pure Nothing -- | Get current user name from the local global git config. getUsername :: IO Text diff --git a/src/Hit/Issue.hs b/src/Hit/Git/Issue.hs similarity index 66% rename from src/Hit/Issue.hs rename to src/Hit/Git/Issue.hs index cff1d28..9d65eeb 100644 --- a/src/Hit/Issue.hs +++ b/src/Hit/Git/Issue.hs @@ -1,73 +1,62 @@ {- | -Module : Hit.Issue -Copyright : (c) 2019-2020 Kowainik +Module : Hit.GitHub.Issue +Copyright : (c) 2021 Kowainik SPDX-License-Identifier : MPL-2.0 Maintainer : Kowainik Stability : Stable Portability : Portable -This module contains functions to work with issues withing GitHub API. +Issue-related queries and data types. -} -module Hit.Issue - ( -- * For CLI commands - runIssue - , createIssue - , assignIssue - , fetchIssue - - -- * Issues helpers - , getAllIssues - , printIssues - - -- * Internal helpers - , meToUsername - , mkIssueId - , getIssueTitle - , showIssueName - -- ** Milestones - , getMilestoneId +module Hit.Git.Issue + ( runIssue ) where import Colourista (blue, blueBg, bold, errorMessage, formatWith, green, red, reset, skipMessage, successMessage, warningMessage) -import Data.Vector (Vector) -import GitHub (Error (..), Id, Issue (..), IssueLabel (..), IssueState (..), Name, SimpleUser (..), - User, getUrl, milestoneNumber, mkId, unIssueNumber, untagName) -import GitHub.Data.Options (stateOpen) -import GitHub.Endpoints.Issues (EditIssue (..), NewIssue (..), editOfIssue, issue', issuesForRepo') -import GitHub.Endpoints.Issues.Milestones (milestones') - -import Hit.Core (IssueOptions (..), Milestone (..)) +import Data.Aeson (Array, FromJSON (..), withObject, (.:)) +import Data.Aeson.Types (Parser) +import Prolens (set) + +import Hit.Core (IssueOptions (..), Milestone (..), Owner (..), Repo (..)) +import Hit.Error (renderHitError) import Hit.Git.Common (getUsername) -import Hit.GitHub (makeName, withAuthOwnerRepo, withOwnerRepo) +import Hit.GitHub.Auth (withAuthOwnerRepo) +import Hit.GitHub.Issue (Issue (..), ShortIssue (..), issueToShort, queryIssue, queryIssueList) import Hit.Prompt (arrow) import qualified Hit.Formatting as Fmt -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified GitHub as G -import qualified GitHub.Endpoints.Issues as GitHub - +import qualified Data.Text as Text +import qualified GitHub as GH ----------------------------------------------------------------------------- --- CLI for issues ----------------------------------------------------------------------------- -- | Run the @issue@ command. runIssue :: IssueOptions -> IO () runIssue IssueOptions{..} = case ioIssueNumber of - Just num -> getIssue $ mkIssueId num + Just num -> getIssue num Nothing -> meToUsername ioMe >>= printFilteredIssues ioMilestone -{- | If requested, get the username. +---------------------------------------------------------------------------- +-- Single issue processing +---------------------------------------------------------------------------- + +-- | Get the 'Issue' by given issue number and pretty print it fully to terminal. +getIssue :: Int -> IO () +getIssue num = fetchIssue num >>= putTextLn . showIssueFull + +{- | Fetch 'Issue' by number. If no issue found then print error and +exit with failure. -} -meToUsername :: Bool -> IO (Maybe Text) -meToUsername isMe = - if isMe - then Just <$> getUsername - else pure Nothing +fetchIssue :: Int -> IO Issue +fetchIssue iNum = withAuthOwnerRepo (\t o r -> queryIssue t o r iNum) >>= \case + Left err -> errorMessage (renderHitError err) >> exitFailure + Right issue -> pure issue + +---------------------------------------------------------------------------- +-- Multiple list processing +---------------------------------------------------------------------------- {- | Outputs the list of the open issues for the current project with applied filters. @@ -80,107 +69,39 @@ printFilteredIssues -> IO () printFilteredIssues milestone me = getAllIssues milestone me >>= printIssues -{- | Outputs the list of the given issues for the current project. --} -printIssues :: Vector Issue -> IO () -printIssues issues = let maxLen = Fmt.maxLenOn showIssueNumber issues in - if V.null issues - then skipMessage "There are no open issues satisfying the provided filters" - else for_ issues $ \i -> do - let thisLen = T.length $ showIssueNumber i - padSize = maxLen - thisLen - putTextLn $ showIssueName blue padSize i - {- | Get the list of the opened issues for the current project filtered out by the given input: + * Only current user's issues? * Only issues from the current/specified milestone? -} getAllIssues :: Maybe Milestone -- ^ Project Milestone -> Maybe Text -- ^ User name of the assignee - -> IO (Vector Issue) -getAllIssues milestone me = withOwnerRepo (\t o r -> issuesForRepo' t o r stateOpen) >>= \case - Left err -> errorMessage (show err) >> exitFailure + -> IO [ShortIssue] +getAllIssues milestone me = withAuthOwnerRepo queryIssueList >>= \case + Left err -> errorMessage (renderHitError err) >> exitFailure Right is -> do milestoneId <- getMilestoneId milestone pure $ filterIssues milestoneId is where - filterIssues :: Maybe (Id G.Milestone) -> Vector Issue -> Vector Issue - filterIssues milestoneId = V.filter - (\i -> - isNotPR i - && my i - && i `isInMilestone` milestoneId - ) + filterIssues :: Maybe (Id G.Milestone) -> [Issue] -> [Issue] + filterIssues milestoneId = + filter (\i -> my i && i `isInMilestone` milestoneId) my :: Issue -> Bool my issue = case me of Just (makeName -> username) -> username `isAssignedToIssue` issue Nothing -> True - isNotPR :: Issue -> Bool - isNotPR Issue{..} = isNothing issuePullRequest - isInMilestone :: Issue -> Maybe (Id G.Milestone) -> Bool isInMilestone Issue{..} = \case Just milestoneId -> (milestoneNumber <$> issueMilestone) == Just milestoneId - Nothing -> True - --- | Show issue number with alignment and its name. -showIssueName :: Text -> Int -> Issue -> Text -showIssueName colorCode padSize i@Issue{..} = - arrow <> colorCode <> " [#" <> showIssueNumber i <> "] " <> padding <> reset <> issueTitle - where - padding :: Text - padding = T.replicate padSize " " - --- | Show the issue number. -showIssueNumber :: Issue -> Text -showIssueNumber = show . unIssueNumber . issueNumber - --- | Get the 'Issue' by given issue number and pretty print it fully to terminal. -getIssue :: Id Issue -> IO () -getIssue num = fetchIssue num >>= putTextLn . showIssueFull - --- | Show full information about the issue. -showIssueFull :: Issue -> Text -showIssueFull i@Issue{..} = T.intercalate "\n" $ - showIssueName (statusToCode issueState) 0 i - : [ highlight " Assignees: " <> assignees | not $ null issueAssignees] - ++ [ highlight " Labels: " <> labels | not $ null issueLabels] - ++ [ highlight " URL: " <> getUrl url | Just url <- [issueHtmlUrl]] - ++ [ indentDesc desc | Just (T.strip -> desc) <- [issueBody], desc /= ""] - where - statusToCode :: IssueState -> Text - statusToCode = \case - StateOpen -> blue - StateClosed -> red - - indentDesc :: Text -> Text - indentDesc = unlines - . map (" " <> ) - . (highlight "Description:" :) - . lines - - assignees :: Text - assignees = T.intercalate ", " - $ map (untagName . simpleUserLogin) - $ toList issueAssignees + Nothing -> True - labels :: Text - labels = T.intercalate " " - $ map (putLabel . untagName . labelName) - $ toList issueLabels - - putLabel :: Text -> Text - putLabel = formatWith [blueBg] - - highlight :: Text -> Text - highlight = formatWith [bold, green] -- | Create an 'Issue' by given title 'Text' --- QUESTION: should we create 'Login' newtype to add more type-safety here? +-- TODO: separate query to create issue in Hit.GitHub.Issue createIssue :: Text -> Text -> Maybe (Id G.Milestone) -> IO (Either Error Issue) createIssue title login milestone = withAuthOwnerRepo $ \token owner repo -> GitHub.createIssue token owner repo $ mkNewIssue title login milestone @@ -195,6 +116,7 @@ This function can fail assignment due to the following reasons: The function should inform user about corresponding 'Error' in each case and continue working. -} +-- TODO: separate query to assign to issue in Hit.GitHub.Issue assignIssue :: Issue -> Text -> IO () assignIssue issue username = do res <- withAuthOwnerRepo $ \token owner repo -> do @@ -228,24 +150,77 @@ isAssignedToIssue :: Name User -> Issue -> Bool isAssignedToIssue assignee = V.elem assignee . V.map simpleUserLogin . issueAssignees +---------------------------------------------------------------------------- +-- Issue formatting +---------------------------------------------------------------------------- + +{- | Outputs the list of the given issues for the current project. +-} +printIssues :: [ShortIssue] -> IO () +printIssues issues = let maxLen = Fmt.maxLenOn showIssueNumber issues in + if null issues + then skipMessage "There are no open issues satisfying the provided filters" + else for_ issues $ \issue@ShortIssue{..} -> do + let thisLen = Text.length $ show shortIssueNumber + padSize = maxLen - thisLen + putTextLn $ showShortIssue blue padSize issue + +-- | Show issue number with alignment and its name. +showShortIssue :: Text -> Int -> ShortIssue -> Text +showShortIssue colorCode padSize ShortIssue{..} = mconcat + [ arrow + , colorCode + , " [#" <> show shortIssueNumber <> "] " + , spaces padSize + , reset + , shortIssueTitle + ] + +-- | Show full information about the issue. +showIssue :: Issue -> Text +showIssue i@Issue{..} = T.intercalate "\n" $ + showShortIssue (statusToCode issueState) 0 (showShortIssue $ issueToShort i) + : [ highlight " Assignees: " <> assignees | not $ null issueAssignees] + ++ [ highlight " Labels: " <> labels | not $ null issueLabels] + ++ [ highlight " URL: " <> getUrl url | Just url <- [issueHtmlUrl]] + ++ [ indentDesc desc | Just (T.strip -> desc) <- [issueBody], desc /= ""] + where + statusToCode :: GH.IssueState -> Text + statusToCode = \case + IssueOpen -> blue + IssueClosed -> red + + indentDesc :: Text -> Text + indentDesc = unlines + . map (" " <> ) + . (highlight "Description:" :) + . lines + + assignees :: Text + assignees = T.intercalate ", " $ map (untagName . simpleUserLogin) issueAssignees + + labels :: Text + labels = T.intercalate " " $ map (putLabel . untagName . labelName) issueLabels + + putLabel :: Text -> Text + putLabel = formatWith [blueBg] + + highlight :: Text -> Text + highlight = formatWith [bold, green] + ---------------------------------------------------------------------------- -- Helper functions ---------------------------------------------------------------------------- -- | Fetch only issue title. -getIssueTitle :: Id Issue -> IO Text +-- TODO: separate GraphQL query to fetch only title +getIssueTitle :: Int -> IO Text getIssueTitle num = issueTitle <$> fetchIssue num -{- | Fetch 'Issue' by 'Id'. If no issue found then print error and -exit with failure. --} -fetchIssue :: Id Issue -> IO Issue -fetchIssue iNum = withOwnerRepo (\t o r -> issue' t o r iNum) >>= \case - Left err -> errorMessage (show err) >> exitFailure - Right issue -> pure issue {- | From the given 'Milestone' type try to get the milestone ID -} +-- TODO: query to fetch the latest milestone in Hit.GitHub.Milestone getMilestoneId :: Maybe Milestone -> IO (Maybe (Id G.Milestone)) getMilestoneId = \case Just (MilestoneId mId) -> pure $ Just $ mkId (Proxy @G.Milestone) mId @@ -265,10 +240,6 @@ fetchCurrentMilestoneId = withOwnerRepo milestones' >>= \case [] -> warningMessage "There are no open milestones for this project" >> pure Nothing m:_ -> pure $ Just m --- | Smart constructor for @'Id' 'Issue'@. -mkIssueId :: Int -> Id Issue -mkIssueId = mkId $ Proxy @Issue - -- | Create new issue with title and assignee. mkNewIssue :: Text -> Text -> Maybe (Id G.Milestone) -> NewIssue mkNewIssue title login milestone = NewIssue diff --git a/src/Hit/GitHub.hs b/src/Hit/GitHub.hs index 03a305e..02c08ef 100644 --- a/src/Hit/GitHub.hs +++ b/src/Hit/GitHub.hs @@ -1,6 +1,6 @@ {- | Module : Hit.GitHub -Copyright : (c) 2020 Kowainik +Copyright : (c) 2020-2021 Kowainik SPDX-License-Identifier : MPL-2.0 Maintainer : Kowainik Stability : Stable @@ -10,110 +10,9 @@ This module contains helper functions to work with GitHub API. -} module Hit.GitHub - ( withOwnerRepo - , withAuthOwnerRepo - - , makeName - , getGitHubToken - - -- * GitHub URLs - , getOwnerRepo - , parseOwnerRepo + ( module Hit.GitHub.Auth + , module Hit.GitHub.Issue ) where -import Colourista (errorMessage) -import GitHub (Error (..), Name, Owner, Repo, mkName) -import GitHub.Auth (Auth (OAuth)) -import Shellmet (($|)) -import System.Environment (lookupEnv) - -import qualified Data.Text as T - - --- | Perform action by given auth token, owner and repo name. -withOwnerRepo - :: (Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error a)) - -> IO (Either Error a) -withOwnerRepo action = getOwnerRepo >>= \case - Just (owner, repo) -> do - token <- getGitHubToken - action token owner repo - Nothing -> do - let errorText = "Cannot get the owner/repo names" - errorMessage errorText - pure $ Left $ ParseError errorText - -{- | Similar to 'withOwnerRepo', but returns the 'UserError' when cannot get the -GitHub Token, as the given action should work with the 'Auth' instead of 'Maybe -Auth'. --} -withAuthOwnerRepo - :: (Auth -> Name Owner -> Name Repo -> IO (Either Error a)) - -> IO (Either Error a) -withAuthOwnerRepo action = withOwnerRepo $ \token owner repo -> case token of - Just auth -> action auth owner repo - Nothing -> do - let errorText = "Can not get GITHUB_TOKEN" - errorMessage errorText - pure $ Left $ UserError errorText - --- | Smart constructor for 'Name'. -makeName :: forall a . Text -> Name a -makeName = mkName (Proxy @a) - --- | Get authentication GitHub token from the environment variable @GITHUB_TOKEN@. -getGitHubToken :: IO (Maybe Auth) -getGitHubToken = do - token <- lookupEnv "GITHUB_TOKEN" - pure $ OAuth . encodeUtf8 <$> token - ----------------------------------------------------------------------------- --- Fetch and parse name and repo from URL ----------------------------------------------------------------------------- - --- | Get the owner and the repository name. -getOwnerRepo :: IO (Maybe (Name Owner, Name Repo)) -getOwnerRepo = parseOwnerRepo <$> "git" $| ["remote", "get-url", "origin"] - -{- | -__Note:__ this works with GitHub projects! - -This function supports four kinds of the URLs: - -SSH one: - -@ -git@github.com:kowainik/hit-on.git -@ - -or - -@ -git@github.com:kowainik/hit-on -@ - -And HTTPS one: - -@ -https://github.com/kowainik/hit-on.git -@ - -or - -@ -https://github.com/kowainik/hit-on -@ --} -parseOwnerRepo :: Text -> Maybe (Name Owner, Name Repo) -parseOwnerRepo url = - ( T.stripPrefix "git@github.com:" url - <|> T.stripPrefix "https://github.com/" url - ) >>= stripGitSuffix >>= separateName - where - separateName :: Text -> Maybe (Name Owner, Name Repo) - separateName nm = - let (owner, T.drop 1 -> repo) = T.breakOn "/" nm in - guard (owner /= "" && repo /= "") *> Just (makeName owner, makeName repo) - - stripGitSuffix :: Text -> Maybe Text - stripGitSuffix x = whenNothing (T.stripSuffix ".git" x) (Just x) +import Hit.GitHub.Auth +import Hit.GitHub.Issue diff --git a/src/Hit/GitHub/Auth.hs b/src/Hit/GitHub/Auth.hs new file mode 100644 index 0000000..dd40207 --- /dev/null +++ b/src/Hit/GitHub/Auth.hs @@ -0,0 +1,99 @@ +{- | +Module : Hit.GitHub.Auth +Copyright : (c) 2021 Kowainik +SPDX-License-Identifier : MPL-2.0 +Maintainer : Kowainik +Stability : Stable +Portability : Portable + +Functions to perform authenticated GitHub API requests. +-} + +module Hit.GitHub.Auth + ( withAuthOwnerRepo + ) where + +import Shellmet (($|)) + +import Hit.Core (Owner, Repo) +import Hit.Error (HitError (..)) + +import qualified Data.Text as Text +import qualified GitHub as GH + + +{- | Perform action by given 'GH.GitHubToken' , 'Owner' and 'Repo. + +All actions to query GraphQL GitHub API require authentication token. +-} +withAuthOwnerRepo + :: (GH.GitHubToken -> Owner -> Repo -> IO a) + -> IO (Either HitError a) +withAuthOwnerRepo action = GH.getGitHubToken "GITHUB_TOKEN" >>= \case + Nothing -> pure $ Left NoGitHubTokenEnv + Just token -> getOwnerRepo >>= \case + Nothing -> pure $ Left InvalidOwnerRepo + Just (owner, repo) -> action token owner repo + +-- withOwnerRepo +-- :: (Maybe Auth -> Name Owner -> Name Repo -> IO (Either Error a)) +-- -> IO (Either Error a) +-- withOwnerRepo action = getOwnerRepo >>= \case +-- Just (owner, repo) -> do +-- token <- getGitHubToken +-- action token owner repo +-- Nothing -> do +-- let errorText = "Cannot get the owner/repo names" +-- errorMessage errorText +-- pure $ Left $ ParseError errorText + +---------------------------------------------------------------------------- +-- Fetch and parse name and repo from URL +---------------------------------------------------------------------------- + +-- | Get the owner and the repository name. +getOwnerRepo :: IO (Maybe (Owner, Repo)) +getOwnerRepo = parseOwnerRepo <$> "git" $| ["remote", "get-url", "origin"] + +{- | +__Note:__ this works with GitHub projects! + +This function supports four kinds of the URLs: + +SSH one: + +@ +git@github.com:kowainik/hit-on.git +@ + +or + +@ +git@github.com:kowainik/hit-on +@ + +And HTTPS one: + +@ +https://github.com/kowainik/hit-on.git +@ + +or + +@ +https://github.com/kowainik/hit-on +@ +-} +parseOwnerRepo :: Text -> Maybe (Owner, Repo) +parseOwnerRepo url = + ( Text.stripPrefix "git@github.com:" url + <|> Text.stripPrefix "https://github.com/" url + ) >>= stripGitSuffix >>= separateName + where + separateName :: Text -> Maybe (Owner, Repo) + separateName nm = + let (owner, Text.drop 1 -> repo) = Text.breakOn "/" nm in + guard (owner /= "" && repo /= "") $> (Owner owner, Repo repo) + + stripGitSuffix :: Text -> Maybe Text + stripGitSuffix x = whenNothing (T.stripSuffix ".git" x) (Just x) diff --git a/src/Hit/GitHub/Issue.hs b/src/Hit/GitHub/Issue.hs new file mode 100644 index 0000000..47657f8 --- /dev/null +++ b/src/Hit/GitHub/Issue.hs @@ -0,0 +1,211 @@ +{- | +Module : Hit.GitHub.Issue +Copyright : (c) 2021 Kowainik +SPDX-License-Identifier : MPL-2.0 +Maintainer : Kowainik +Stability : Stable +Portability : Portable + +Issue-related queries and data types. +-} + +module Hit.GitHub.Issue + ( Issue (..) + , queryIssue + + , ShortIssue (..) + , queryIssueList + , issueToShort + ) where + +import Data.Aeson (Array, FromJSON (..), withObject, (.:)) +import Data.Aeson.Types (Parser) +import Prolens (set) + +import Hit.Core (IssueOptions (..), Milestone (..), Owner (..), Repo (..)) +import Hit.Error (renderHitError) +import Hit.Git.Common (getUsername) +import Hit.GitHub.RepositoryNode (RepositoryNode (..)) +import Hit.Prompt (arrow) + +import qualified Hit.Formatting as Fmt + +import qualified Data.Text as Text +import qualified GitHub as GH + +---------------------------------------------------------------------------- +-- Big issue type +---------------------------------------------------------------------------- + +{- | Issue with all information about it. +-} +data Issue = Issue + { issueTitle :: Text + , issueAuthorLogin :: Text + , issueBody :: Text + , issueNumber :: Int + , issueUrl :: Text + , issueState :: GH.IssueState + , issueLabels :: [Text] + , issueAssignees :: [Text] + } + +instance FromJSON Issue + where + parseJSON = withObject "Issue" $ \o -> do + repository <- o .: "repository" + i <- repository .: "issue" + + issueTitle <- i .: "title" + author <- i .: "author" + issueAuthorLogin <- author .: "login" + issueBody <- i .: "body" + issueNumber <- i .: "number" + issueUrl <- i .: "url" + issueState <- i .: "state" + + labels <- i .: "labels" + labelNodes <- labels .: "nodes" + issueLabels <- parseLabels labelNodes + + assignees <- i .: "assignees" + assigneesNodes <- assignees .: "nodes" + issueAssignees <- parseAssignees assigneesNodes + + pure Issue{..} + where + parseLabels :: Array -> Parser [Text] + parseLabels = mapM (withObject "Label" $ \o -> o .: "name") . toList + +{- | Query for the specific issue with full details. +-} +issueQuery :: Owner -> Repo -> Int -> GH.Repository +issueQuery (Owner owner) (Repo repo) issueNumber = GH.repository + ( GH.defRepositoryArgs + & set GH.ownerL owner + & set GH.nameL repo + ) + $ one + $ GH.issue + ( GH.defIssueArgs + & set GH.numberL issueNumber + & set GH.statesL (one GH.open) + & set GH.orderL + ( Just $ GH.defOrder + & set GH.fieldL GH.CreatedAt + & set GH.directionL GH.Asc + ) + ) + ( one + $ GH.nodes + $ GH.title + :| [ GH.author $ one GH.login + , GH.IssueBody + , GH.IssueNumber + , GH.IssueUrl + , GH.IssueState + , GH.IssueLabels + $ GH.Labels + ( GH.defLabelsArgs + & set GH.lastL 5 + ) + (GH.nodes $ GH.one GH.LabelName) + , GH.IssueAssignees + $ GH.Assignees + ( GH.defAssigneesArgs + & set GH.lastL 5 + ) + (GH.nodes $ one GH.UserLogin) + ] + ) + +{- | Queries a single issue by number. +-} +queryIssue :: GH.GitHubToken -> Owner -> Repo -> Int -> IO Issue +queryIssue token owner repo issueNumber = GH.queryGitHub + token + (GH.repositoryToAst $ issueQuery owner repo issueNumber) + +---------------------------------------------------------------------------- +-- Small issue type +---------------------------------------------------------------------------- + +{- | GitHub issue with only small amount of information about it. +-} +data ShortIssue = ShortIssue + { shortIssueNumber :: Int + , shortIssueTitle :: Text + , shortIssueAuthorLogin :: Text + , shortIssueAssignees :: [Text] + } + +instance FromJSON ShortIssue + where + parseJSON = withObject "Issue" $ \o -> do + shortIssueTitle <- o .: "title" + author <- o .: "author" + shortIssueAuthorLogin <- author .: "login" + shortIssueNumber <- o .: "number" + + assignees <- o .: "assignees" + assigneesNodes <- assignees .: "nodes" + shortIssueAssignees <- parseAssignees assigneesNodes + + pure ShortIssue{..} + where + +issueToShort :: Issue -> ShortIssue +issueToShort Issue{..} = ShortIssue + { shortIssueNumber = issueNumber + , shortIssueTitle = issueTitle + , shortIssueAuthorLogin = issueAuthorLogin + , shortIssueAssignees = issueAssignees + } + +issueListQuery :: Owner -> Repo -> GH.Repository +issueListQuery (Owner owner) (Repo repo) = GH.repository + ( GH.defRepositoryArgs + & set GH.ownerL owner + & set GH.nameL repo + ) + $ one + $ GH.issues + ( GH.defIssuesArgs + & set GH.lastL 100 + & set GH.statesL (one GH.open) + & set GH.orderL + ( Just $ GH.defOrder + & set GH.fieldL GH.CreatedAt + & set GH.directionL GH.Asc + ) + ) + ( one + $ GH.nodes + $ GH.title + :| [ GH.author $ one GH.login + , GH.IssueNumber + , GH.IssueAssignees + $ GH.Assignees + ( GH.defAssigneesArgs + & set GH.lastL 5 + ) + (GH.nodes $ one GH.UserLogin) + ] + ) + +{- | Queries the latest 100 issues of the repository. +-} +queryIssueList :: GH.GitHubToken -> Owner -> Repo -> IO [ShortIssue] +queryIssueList token owner repo = + unRepositoryNodes <$> + GH.queryGitHub + @(RepositoryNodes "issues" ShortIssue) + token + (GH.repositoryToAst $ issueListQuery owner repo) + +---------------------------------------------------------------------------- +-- Internals +---------------------------------------------------------------------------- + +parseAssignees :: Array -> Parser [Text] +parseAssignees = mapM (withObject "Assignee" $ \o -> o .: "login") . toList diff --git a/src/Hit/GitHub/Milestone.hs b/src/Hit/GitHub/Milestone.hs new file mode 100644 index 0000000..20292fa --- /dev/null +++ b/src/Hit/GitHub/Milestone.hs @@ -0,0 +1,74 @@ +{- | +Module : Hit.GitHub.Milestone +Copyright : (c) 2021 Kowainik +SPDX-License-Identifier : MPL-2.0 +Maintainer : Kowainik +Stability : Stable +Portability : Portable + +Milestone-related queries and data types. +-} + +module Hit.GitHub.Milestone + ( Milestone (..) + ) where + +import Prolens (set) + +import Hit.Core (Owner (..), Repo (..)) + +import qualified GitHub as GH + + +data Milestone = Milestone + { milestoneId :: Text + , milestoneNumber :: Int + , milestoneTitle :: Text + , milestoneProgressPercentage :: Double + , milestoneTotalIssues :: Int + } deriving stock (Show, Eq) + +instance FromJSON Milestone + where + parseJSON = withObject "Milestone" $ \o -> do + milestoneId <- o .: "id" + milestoneNumber <- o .: "number" + milestoneTitle <- o .: "title" + + milestoneProgressPercentage <- o .: "progressPercentage" + + issues <- o .: "issues" + milestoneTotalIssues <- issues .: "totalCount" + + pure Milestone{..} + +milestonesQuery :: Owner -> Repo -> GH.Repository +milestonesQuery (Owner owner) (Repo repo) = GH.repository + ( GH.defRepositoryArgs + & set GH.ownerL owner + & set GH.nameL repo + ) + $ one + $ GH.milestones + ( GH.defMilestonesArgs + & set GH.lastL 100 + & set GH.orderL + ( Just $ GH.defOrder + & set GH.fieldL GH.CreatedAt + & set GH.directionL GH.Desc + ) + ) + ( one + $ GH.nodes + $ GH.MilestoneId + :| [ GH.MilestoneNumber + , GH.MilestoneProgressPercentage + , GH.MilestoneTitle + , GH.MilestoneIssues $ GH.Issues + ( GH.defIssuesArgs + & set GH.lastL 1000 + & set GH.statesL (universeNonEmpty @GH.IssueState) + ) + (one GH.TotalCount) + ] + ) diff --git a/src/Hit/GitHub/Repository.hs b/src/Hit/GitHub/Repository.hs new file mode 100644 index 0000000..0d80ae7 --- /dev/null +++ b/src/Hit/GitHub/Repository.hs @@ -0,0 +1,45 @@ +{- | +Module : Hit.GitHub.Repository +Copyright : (c) 2021 Kowainik +SPDX-License-Identifier : MPL-2.0 +Maintainer : Kowainik +Stability : Stable +Portability : Portable + +Repository-related queries and data types. +-} + +module Hit.GitHub.Repository + ( RepositoryNodes (..) + ) where + +import Data.Aeson (FromJSON (..), withObject, (.:)) + + +{- | Helper type to parse nodes of the top-level @repository@ query. + +The JSON usually has the following shape: + +@ +{ + "data": { + "repository": { + "": { + "nodes": [ + ... +@ +-} +newtype RepositoryNodes (name :: Symbol) a = RepositoryNode + { unRepositoryNodes :: [a] + } + +instance + (KnownSymbol name, FromJSON a, Typeable a) + => FromJSON (RepositoryNode name a) + where + parseJSON = withObject ("RepositoryNode " <> typeName @a) $ \o -> do + repository <- o .: "repository" + let itemName = symbolVal (Proxy @name) + items <- repository .: itemName + nodes <- items .: "nodes" + RepositoryNode <$> mapM parseJSON nodes