{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Utils.ThankYouStars.GitHub (
Token(..)
, GitHubRepo(..)
, readToken
, starRepo
) where
import Control.Exception ( catch, throwIO )
import Data.Aeson
import Data.ByteString ( ByteString )
import qualified Data.ByteString.Lazy as BSL
import Data.String ( fromString )
import Data.Text.Encoding ( encodeUtf8 )
import Data.Version ( showVersion )
import Network.HTTP.Req
import Paths_thank_you_stars ( version )
data Token = Token {
Token -> ByteString
unToken :: ByteString
} deriving ( Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq, Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show )
instance FromJSON Token where
parseJSON :: Value -> Parser Token
parseJSON (Object Object
v) = ByteString -> Token
Token (ByteString -> Token) -> (Text -> ByteString) -> Text -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> Token) -> Parser Text -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"token"
parseJSON Value
_ = String -> Parser Token
forall a. HasCallStack => String -> a
error String
"invalid format"
readToken :: FilePath -> IO (Either String Token)
readToken :: String -> IO (Either String Token)
readToken String
fp = ByteString -> Either String Token
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String Token)
-> IO ByteString -> IO (Either String Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BSL.readFile String
fp
data GitHubRepo = GitHubRepo {
GitHubRepo -> String
owner :: String
, GitHubRepo -> String
repo :: String
} deriving ( GitHubRepo -> GitHubRepo -> Bool
(GitHubRepo -> GitHubRepo -> Bool)
-> (GitHubRepo -> GitHubRepo -> Bool) -> Eq GitHubRepo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GitHubRepo -> GitHubRepo -> Bool
$c/= :: GitHubRepo -> GitHubRepo -> Bool
== :: GitHubRepo -> GitHubRepo -> Bool
$c== :: GitHubRepo -> GitHubRepo -> Bool
Eq, Eq GitHubRepo
Eq GitHubRepo
-> (GitHubRepo -> GitHubRepo -> Ordering)
-> (GitHubRepo -> GitHubRepo -> Bool)
-> (GitHubRepo -> GitHubRepo -> Bool)
-> (GitHubRepo -> GitHubRepo -> Bool)
-> (GitHubRepo -> GitHubRepo -> Bool)
-> (GitHubRepo -> GitHubRepo -> GitHubRepo)
-> (GitHubRepo -> GitHubRepo -> GitHubRepo)
-> Ord GitHubRepo
GitHubRepo -> GitHubRepo -> Bool
GitHubRepo -> GitHubRepo -> Ordering
GitHubRepo -> GitHubRepo -> GitHubRepo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: GitHubRepo -> GitHubRepo -> GitHubRepo
$cmin :: GitHubRepo -> GitHubRepo -> GitHubRepo
max :: GitHubRepo -> GitHubRepo -> GitHubRepo
$cmax :: GitHubRepo -> GitHubRepo -> GitHubRepo
>= :: GitHubRepo -> GitHubRepo -> Bool
$c>= :: GitHubRepo -> GitHubRepo -> Bool
> :: GitHubRepo -> GitHubRepo -> Bool
$c> :: GitHubRepo -> GitHubRepo -> Bool
<= :: GitHubRepo -> GitHubRepo -> Bool
$c<= :: GitHubRepo -> GitHubRepo -> Bool
< :: GitHubRepo -> GitHubRepo -> Bool
$c< :: GitHubRepo -> GitHubRepo -> Bool
compare :: GitHubRepo -> GitHubRepo -> Ordering
$ccompare :: GitHubRepo -> GitHubRepo -> Ordering
$cp1Ord :: Eq GitHubRepo
Ord )
instance Show GitHubRepo where
show :: GitHubRepo -> String
show GitHubRepo
ghr = String
"https://github.com/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ GitHubRepo -> String
owner GitHubRepo
ghr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ GitHubRepo -> String
repo GitHubRepo
ghr
starringUrl :: GitHubRepo -> Url 'Https
starringUrl :: GitHubRepo -> Url 'Https
starringUrl GitHubRepo
ghr =
Text -> Url 'Https
https Text
"api.github.com" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"user" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"starred" Url 'Https -> String -> Url 'Https
forall a (scheme :: Scheme).
ToHttpApiData a =>
Url scheme -> a -> Url scheme
/~ GitHubRepo -> String
owner GitHubRepo
ghr Url 'Https -> String -> Url 'Https
forall a (scheme :: Scheme).
ToHttpApiData a =>
Url scheme -> a -> Url scheme
/~ GitHubRepo -> String
repo GitHubRepo
ghr
userAgent :: Option scheme
userAgent :: Option scheme
userAgent = ByteString -> ByteString -> Option scheme
forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"User-Agent" ByteString
agent
where
agent :: ByteString
agent = ByteString
"thank-you-stars/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
forall a. IsString a => String -> a
fromString (Version -> String
showVersion Version
version)
instance MonadHttp IO where
handleHttpException :: HttpException -> IO a
handleHttpException = HttpException -> IO a
forall e a. Exception e => e -> IO a
throwIO
starRepo :: Token -> GitHubRepo -> IO (Either HttpException ())
starRepo :: Token -> GitHubRepo -> IO (Either HttpException ())
starRepo Token
token GitHubRepo
ghr =
(do
let headers :: Option 'Https
headers = ByteString -> Option 'Https
oAuth2Token (Token -> ByteString
unToken Token
token) Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> Option 'Https
forall (scheme :: Scheme). Option scheme
userAgent
IgnoreResponse
_ <- PUT
-> Url 'Https
-> NoReqBody
-> Proxy IgnoreResponse
-> Option 'Https
-> IO IgnoreResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req PUT
PUT (GitHubRepo -> Url 'Https
starringUrl GitHubRepo
ghr) NoReqBody
NoReqBody Proxy IgnoreResponse
ignoreResponse Option 'Https
headers
Either HttpException () -> IO (Either HttpException ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HttpException () -> IO (Either HttpException ()))
-> Either HttpException () -> IO (Either HttpException ())
forall a b. (a -> b) -> a -> b
$ () -> Either HttpException ()
forall a b. b -> Either a b
Right ()
) IO (Either HttpException ())
-> (HttpException -> IO (Either HttpException ()))
-> IO (Either HttpException ())
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(HttpException
e :: HttpException) -> do
Either HttpException () -> IO (Either HttpException ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HttpException () -> IO (Either HttpException ()))
-> Either HttpException () -> IO (Either HttpException ())
forall a b. (a -> b) -> a -> b
$ HttpException -> Either HttpException ()
forall a b. a -> Either a b
Left HttpException
e
)