-
-
Notifications
You must be signed in to change notification settings - Fork 13
/
Issue.hs
107 lines (84 loc) · 3.18 KB
/
Issue.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
module Hit.Issue
( runIssue
-- * Internal helpers
, mkIssueId
, getIssueTitle
, getOwnerRepo
, parseOwnerRepo
) where
import GitHub (Error (..), Id, Issue (..), IssueState (..), Name, Owner, Repo, getUrl, mkId, mkName)
import GitHub.Data.Options (stateOpen)
import GitHub.Endpoints.Issues (issue, issuesForRepo)
import Hit.ColorTerminal (arrow, blueCode, errorMessage, redCode, resetCode)
import Hit.Shell (($|))
import qualified Data.Text as T
-- | Run the @issue@ command.
runIssue :: Maybe Int -> IO ()
runIssue = \case
Just num -> getIssue $ mkIssueId num
Nothing -> getAllIssues
-- | Get the list of the opened issues for the current project.
getAllIssues :: IO ()
getAllIssues = withOwnerRepo (\o r -> issuesForRepo o r stateOpen) >>= \case
Left err -> errorMessage $ show err
Right is -> for_ is (putTextLn . showIssueName blueCode)
-- | Get the 'Issue' by given issue number.
getIssue :: Id Issue -> IO ()
getIssue num = fetchIssue num >>= \case
Left err -> errorMessage $ show err
Right is -> putTextLn $ showIssueFull is
showIssueName :: Text -> Issue -> Text
showIssueName colorCode Issue{..} =
arrow <> colorCode <> "[#" <> show @Text issueNumber <> "] " <> resetCode <> issueTitle
showIssueFull :: Issue -> Text
showIssueFull i@Issue{..} = T.intercalate "\n" $
showIssueName (statusToCode issueState) i
: [ " URL: " <> getUrl url | Just url <- [issueHtmlUrl]]
++ [ " " <> desc | Just (T.strip -> desc) <- [issueBody], desc /= ""]
where
statusToCode :: IssueState -> Text
statusToCode = \case
StateOpen -> blueCode
StateClosed -> redCode
mkIssueId :: Int -> Id Issue
mkIssueId = mkId $ Proxy @Issue
makeName :: forall a . Text -> Name a
makeName = mkName (Proxy @a)
fetchIssue :: Id Issue -> IO (Either Error Issue)
fetchIssue iNum = withOwnerRepo (\o r -> issue o r iNum)
getIssueTitle :: Id Issue -> IO Text
getIssueTitle num = fetchIssue num >>= \case
Left err -> errorMessage (show err) >> exitFailure
Right Issue{..} -> pure issueTitle
withOwnerRepo :: (Name Owner -> Name Repo -> IO (Either Error a)) -> IO (Either Error a)
withOwnerRepo action = getOwnerRepo >>= \case
Just (owner, repo) -> action owner repo
Nothing -> do
let errTxt = "Can not get the owner/repo names"
errorMessage errTxt
pure $ Left $ ParseError errTxt
-- | 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 two kinds of the URLs:
SSH one:
@
git@github.com:kowainik/hit-on.git
@
And HTTPS one:
@
https://github.com/kowainik/hit-on.git
@
-}
parseOwnerRepo :: Text -> Maybe (Name Owner, Name Repo)
parseOwnerRepo url =
( T.stripPrefix "git@github.com:" url
<|> T.stripPrefix "https://github.com/" url
) >>= T.stripSuffix ".git" >>= 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)