module GitHub.App.Token.Generate
  ( InstallationId (..)
  , AccessToken (..)
  , generateInstallationToken

    -- * Finding installations by owner
  , Owner (..)
  , generateOwnerToken

    -- * Scoping 'AccessToken's
  , CreateAccessToken (..)
  , module GitHub.App.Token.Permissions
  , generateInstallationTokenScoped
  , generateOwnerTokenScoped

    -- * Errors
  , InvalidPrivateKey (..)
  , InvalidDate (..)
  , InvalidIssuer (..)
  , AccessTokenHttpError (..)
  , AccessTokenJsonDecodeError (..)
  , GetInstallationHttpError (..)
  , GetInstallationJsonDecodeError (..)
  ) where

import GitHub.App.Token.Prelude

import Data.Aeson (FromJSON, ToJSON, eitherDecode)
import Data.ByteString.Lazy qualified as BSL
import Data.Semigroup.Generic
import GitHub.App.Token.AppCredentials
import GitHub.App.Token.JWT
import GitHub.App.Token.Permissions
import Network.HTTP.Simple
  ( Request
  , addRequestHeader
  , getResponseBody
  , getResponseStatus
  , httpLBS
  , parseRequest
  , setRequestBodyJSON
  , setRequestMethod
  )
import Network.HTTP.Types.Header (hAccept, hAuthorization, hUserAgent)
import Network.HTTP.Types.Status (Status, statusIsSuccessful)

{-# ANN module ("HLint: ignore Redundant id" :: String) #-}

newtype InstallationId = InstallationId
  { InstallationId -> Int
unwrap :: Int
  }
  deriving newtype (Maybe InstallationId
Value -> Parser [InstallationId]
Value -> Parser InstallationId
(Value -> Parser InstallationId)
-> (Value -> Parser [InstallationId])
-> Maybe InstallationId
-> FromJSON InstallationId
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser InstallationId
parseJSON :: Value -> Parser InstallationId
$cparseJSONList :: Value -> Parser [InstallationId]
parseJSONList :: Value -> Parser [InstallationId]
$comittedField :: Maybe InstallationId
omittedField :: Maybe InstallationId
FromJSON)

data AccessToken = AccessToken
  { AccessToken -> Text
token :: Text
  , AccessToken -> UTCTime
expires_at :: UTCTime
  }
  deriving stock (Int -> AccessToken -> ShowS
[AccessToken] -> ShowS
AccessToken -> String
(Int -> AccessToken -> ShowS)
-> (AccessToken -> String)
-> ([AccessToken] -> ShowS)
-> Show AccessToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AccessToken -> ShowS
showsPrec :: Int -> AccessToken -> ShowS
$cshow :: AccessToken -> String
show :: AccessToken -> String
$cshowList :: [AccessToken] -> ShowS
showList :: [AccessToken] -> ShowS
Show, (forall x. AccessToken -> Rep AccessToken x)
-> (forall x. Rep AccessToken x -> AccessToken)
-> Generic AccessToken
forall x. Rep AccessToken x -> AccessToken
forall x. AccessToken -> Rep AccessToken x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AccessToken -> Rep AccessToken x
from :: forall x. AccessToken -> Rep AccessToken x
$cto :: forall x. Rep AccessToken x -> AccessToken
to :: forall x. Rep AccessToken x -> AccessToken
Generic)
  deriving anyclass (Maybe AccessToken
Value -> Parser [AccessToken]
Value -> Parser AccessToken
(Value -> Parser AccessToken)
-> (Value -> Parser [AccessToken])
-> Maybe AccessToken
-> FromJSON AccessToken
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser AccessToken
parseJSON :: Value -> Parser AccessToken
$cparseJSONList :: Value -> Parser [AccessToken]
parseJSONList :: Value -> Parser [AccessToken]
$comittedField :: Maybe AccessToken
omittedField :: Maybe AccessToken
FromJSON)

data AccessTokenHttpError = AccessTokenHttpError
  { AccessTokenHttpError -> Status
status :: Status
  , AccessTokenHttpError -> ByteString
body :: BSL.ByteString
  }
  deriving stock (Int -> AccessTokenHttpError -> ShowS
[AccessTokenHttpError] -> ShowS
AccessTokenHttpError -> String
(Int -> AccessTokenHttpError -> ShowS)
-> (AccessTokenHttpError -> String)
-> ([AccessTokenHttpError] -> ShowS)
-> Show AccessTokenHttpError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AccessTokenHttpError -> ShowS
showsPrec :: Int -> AccessTokenHttpError -> ShowS
$cshow :: AccessTokenHttpError -> String
show :: AccessTokenHttpError -> String
$cshowList :: [AccessTokenHttpError] -> ShowS
showList :: [AccessTokenHttpError] -> ShowS
Show)
  deriving anyclass (Show AccessTokenHttpError
Typeable AccessTokenHttpError
(Typeable AccessTokenHttpError, Show AccessTokenHttpError) =>
(AccessTokenHttpError -> SomeException)
-> (SomeException -> Maybe AccessTokenHttpError)
-> (AccessTokenHttpError -> String)
-> Exception AccessTokenHttpError
SomeException -> Maybe AccessTokenHttpError
AccessTokenHttpError -> String
AccessTokenHttpError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: AccessTokenHttpError -> SomeException
toException :: AccessTokenHttpError -> SomeException
$cfromException :: SomeException -> Maybe AccessTokenHttpError
fromException :: SomeException -> Maybe AccessTokenHttpError
$cdisplayException :: AccessTokenHttpError -> String
displayException :: AccessTokenHttpError -> String
Exception)

data AccessTokenJsonDecodeError = AccessTokenJsonDecodeError
  { AccessTokenJsonDecodeError -> ByteString
body :: BSL.ByteString
  , AccessTokenJsonDecodeError -> String
message :: String
  }
  deriving stock (Int -> AccessTokenJsonDecodeError -> ShowS
[AccessTokenJsonDecodeError] -> ShowS
AccessTokenJsonDecodeError -> String
(Int -> AccessTokenJsonDecodeError -> ShowS)
-> (AccessTokenJsonDecodeError -> String)
-> ([AccessTokenJsonDecodeError] -> ShowS)
-> Show AccessTokenJsonDecodeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AccessTokenJsonDecodeError -> ShowS
showsPrec :: Int -> AccessTokenJsonDecodeError -> ShowS
$cshow :: AccessTokenJsonDecodeError -> String
show :: AccessTokenJsonDecodeError -> String
$cshowList :: [AccessTokenJsonDecodeError] -> ShowS
showList :: [AccessTokenJsonDecodeError] -> ShowS
Show)
  deriving anyclass (Show AccessTokenJsonDecodeError
Typeable AccessTokenJsonDecodeError
(Typeable AccessTokenJsonDecodeError,
 Show AccessTokenJsonDecodeError) =>
(AccessTokenJsonDecodeError -> SomeException)
-> (SomeException -> Maybe AccessTokenJsonDecodeError)
-> (AccessTokenJsonDecodeError -> String)
-> Exception AccessTokenJsonDecodeError
SomeException -> Maybe AccessTokenJsonDecodeError
AccessTokenJsonDecodeError -> String
AccessTokenJsonDecodeError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: AccessTokenJsonDecodeError -> SomeException
toException :: AccessTokenJsonDecodeError -> SomeException
$cfromException :: SomeException -> Maybe AccessTokenJsonDecodeError
fromException :: SomeException -> Maybe AccessTokenJsonDecodeError
$cdisplayException :: AccessTokenJsonDecodeError -> String
displayException :: AccessTokenJsonDecodeError -> String
Exception)

-- | Generate a token for all repositories and the installation's permissions
--
-- See 'generateInstallationTokenScoped' for changing either of these.
generateInstallationToken
  :: MonadIO m
  => AppCredentials
  -> InstallationId
  -> m AccessToken
generateInstallationToken :: forall (m :: * -> *).
MonadIO m =>
AppCredentials -> InstallationId -> m AccessToken
generateInstallationToken = CreateAccessToken
-> AppCredentials -> InstallationId -> m AccessToken
forall (m :: * -> *).
MonadIO m =>
CreateAccessToken
-> AppCredentials -> InstallationId -> m AccessToken
generateInstallationTokenScoped CreateAccessToken
forall a. Monoid a => a
mempty

data Owner = Org Text | User Text

generateOwnerToken
  :: MonadIO m
  => AppCredentials
  -> Owner
  -> m AccessToken
generateOwnerToken :: forall (m :: * -> *).
MonadIO m =>
AppCredentials -> Owner -> m AccessToken
generateOwnerToken = CreateAccessToken -> AppCredentials -> Owner -> m AccessToken
forall (m :: * -> *).
MonadIO m =>
CreateAccessToken -> AppCredentials -> Owner -> m AccessToken
generateOwnerTokenScoped CreateAccessToken
forall a. Monoid a => a
mempty

-- | <https://docs.github.com/en/rest/apps/apps?apiVersion=2022-11-28#create-an-installation-access-token-for-an-app>
data CreateAccessToken = CreateAccessToken
  { CreateAccessToken -> [Text]
repositories :: [Text]
  -- ^ List of @{owner}/{name}@ values
  , CreateAccessToken -> [Int]
repository_ids :: [Int]
  , CreateAccessToken -> Permissions
permissions :: Permissions
  }
  deriving stock (CreateAccessToken -> CreateAccessToken -> Bool
(CreateAccessToken -> CreateAccessToken -> Bool)
-> (CreateAccessToken -> CreateAccessToken -> Bool)
-> Eq CreateAccessToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CreateAccessToken -> CreateAccessToken -> Bool
== :: CreateAccessToken -> CreateAccessToken -> Bool
$c/= :: CreateAccessToken -> CreateAccessToken -> Bool
/= :: CreateAccessToken -> CreateAccessToken -> Bool
Eq, (forall x. CreateAccessToken -> Rep CreateAccessToken x)
-> (forall x. Rep CreateAccessToken x -> CreateAccessToken)
-> Generic CreateAccessToken
forall x. Rep CreateAccessToken x -> CreateAccessToken
forall x. CreateAccessToken -> Rep CreateAccessToken x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CreateAccessToken -> Rep CreateAccessToken x
from :: forall x. CreateAccessToken -> Rep CreateAccessToken x
$cto :: forall x. Rep CreateAccessToken x -> CreateAccessToken
to :: forall x. Rep CreateAccessToken x -> CreateAccessToken
Generic)
  deriving anyclass ([CreateAccessToken] -> Value
[CreateAccessToken] -> Encoding
CreateAccessToken -> Bool
CreateAccessToken -> Value
CreateAccessToken -> Encoding
(CreateAccessToken -> Value)
-> (CreateAccessToken -> Encoding)
-> ([CreateAccessToken] -> Value)
-> ([CreateAccessToken] -> Encoding)
-> (CreateAccessToken -> Bool)
-> ToJSON CreateAccessToken
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: CreateAccessToken -> Value
toJSON :: CreateAccessToken -> Value
$ctoEncoding :: CreateAccessToken -> Encoding
toEncoding :: CreateAccessToken -> Encoding
$ctoJSONList :: [CreateAccessToken] -> Value
toJSONList :: [CreateAccessToken] -> Value
$ctoEncodingList :: [CreateAccessToken] -> Encoding
toEncodingList :: [CreateAccessToken] -> Encoding
$comitField :: CreateAccessToken -> Bool
omitField :: CreateAccessToken -> Bool
ToJSON)
  deriving (NonEmpty CreateAccessToken -> CreateAccessToken
CreateAccessToken -> CreateAccessToken -> CreateAccessToken
(CreateAccessToken -> CreateAccessToken -> CreateAccessToken)
-> (NonEmpty CreateAccessToken -> CreateAccessToken)
-> (forall b.
    Integral b =>
    b -> CreateAccessToken -> CreateAccessToken)
-> Semigroup CreateAccessToken
forall b. Integral b => b -> CreateAccessToken -> CreateAccessToken
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: CreateAccessToken -> CreateAccessToken -> CreateAccessToken
<> :: CreateAccessToken -> CreateAccessToken -> CreateAccessToken
$csconcat :: NonEmpty CreateAccessToken -> CreateAccessToken
sconcat :: NonEmpty CreateAccessToken -> CreateAccessToken
$cstimes :: forall b. Integral b => b -> CreateAccessToken -> CreateAccessToken
stimes :: forall b. Integral b => b -> CreateAccessToken -> CreateAccessToken
Semigroup, Semigroup CreateAccessToken
CreateAccessToken
Semigroup CreateAccessToken =>
CreateAccessToken
-> (CreateAccessToken -> CreateAccessToken -> CreateAccessToken)
-> ([CreateAccessToken] -> CreateAccessToken)
-> Monoid CreateAccessToken
[CreateAccessToken] -> CreateAccessToken
CreateAccessToken -> CreateAccessToken -> CreateAccessToken
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: CreateAccessToken
mempty :: CreateAccessToken
$cmappend :: CreateAccessToken -> CreateAccessToken -> CreateAccessToken
mappend :: CreateAccessToken -> CreateAccessToken -> CreateAccessToken
$cmconcat :: [CreateAccessToken] -> CreateAccessToken
mconcat :: [CreateAccessToken] -> CreateAccessToken
Monoid) via GenericSemigroupMonoid CreateAccessToken

generateInstallationTokenScoped
  :: MonadIO m
  => CreateAccessToken
  -> AppCredentials
  -> InstallationId
  -> m AccessToken
generateInstallationTokenScoped :: forall (m :: * -> *).
MonadIO m =>
CreateAccessToken
-> AppCredentials -> InstallationId -> m AccessToken
generateInstallationTokenScoped CreateAccessToken
create AppCredentials
creds InstallationId
installationId = do
  Request
req <-
    String -> m Request
forall (m :: * -> *). MonadIO m => String -> m Request
githubRequest
      (String -> m Request) -> String -> m Request
forall a b. (a -> b) -> a -> b
$ String
"/app/installations/"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show InstallationId
installationId.unwrap
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/access_tokens"

  -- Avoid encoding to "{}", which causes a 500
  let setBody :: Request -> Request
setBody = if CreateAccessToken
create CreateAccessToken -> CreateAccessToken -> Bool
forall a. Eq a => a -> a -> Bool
== CreateAccessToken
forall a. Monoid a => a
mempty then Request -> Request
forall a. a -> a
id else CreateAccessToken -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON CreateAccessToken
create

  (Status -> ByteString -> AccessTokenHttpError)
-> (ByteString -> String -> AccessTokenJsonDecodeError)
-> AppCredentials
-> Request
-> m AccessToken
forall (m :: * -> *) a e1 e2.
(MonadIO m, FromJSON a, Exception e1, Exception e2) =>
(Status -> ByteString -> e1)
-> (ByteString -> String -> e2) -> AppCredentials -> Request -> m a
appHttpJSON Status -> ByteString -> AccessTokenHttpError
AccessTokenHttpError ByteString -> String -> AccessTokenJsonDecodeError
AccessTokenJsonDecodeError AppCredentials
creds
    (Request -> m AccessToken) -> Request -> m AccessToken
forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
setRequestMethod ByteString
"POST"
    (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request -> Request
setBody Request
req

generateOwnerTokenScoped
  :: MonadIO m
  => CreateAccessToken
  -> AppCredentials
  -> Owner
  -> m AccessToken
generateOwnerTokenScoped :: forall (m :: * -> *).
MonadIO m =>
CreateAccessToken -> AppCredentials -> Owner -> m AccessToken
generateOwnerTokenScoped CreateAccessToken
create AppCredentials
creds Owner
owner = do
  -- If a repositories scope is given, use the first one (along with owner) to
  -- get the installation. Otherwise use the org or user endpoint. This matches
  -- how actions/create-github-app-token works:
  --
  -- https://github.com/actions/create-github-app-token/blob/5d869da34e18e7287c1daad50e0b8ea0f506ce69/lib/main.js#L113-L166
  --
  Installation
installation <- AppCredentials -> Text -> m Installation
forall (m :: * -> *).
MonadIO m =>
AppCredentials -> Text -> m Installation
getInstallation AppCredentials
creds (Text -> m Installation) -> Text -> m Installation
forall a b. (a -> b) -> a -> b
$ case (CreateAccessToken
create.repositories, Owner
owner) of
    (Text
repo : [Text]
_, Org Text
org) -> Text
"/repos/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
org Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
repo
    (Text
repo : [Text]
_, User Text
username) -> Text
"/repos/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
username Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
repo
    ([], Org Text
org) -> Text
"/orgs/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
org
    ([], User Text
username) -> Text
"/users/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
username

  CreateAccessToken
-> AppCredentials -> InstallationId -> m AccessToken
forall (m :: * -> *).
MonadIO m =>
CreateAccessToken
-> AppCredentials -> InstallationId -> m AccessToken
generateInstallationTokenScoped CreateAccessToken
create AppCredentials
creds Installation
installation.id

newtype Installation = Installation
  { Installation -> InstallationId
id :: InstallationId
  }
  deriving stock ((forall x. Installation -> Rep Installation x)
-> (forall x. Rep Installation x -> Installation)
-> Generic Installation
forall x. Rep Installation x -> Installation
forall x. Installation -> Rep Installation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Installation -> Rep Installation x
from :: forall x. Installation -> Rep Installation x
$cto :: forall x. Rep Installation x -> Installation
to :: forall x. Rep Installation x -> Installation
Generic)
  deriving anyclass (Maybe Installation
Value -> Parser [Installation]
Value -> Parser Installation
(Value -> Parser Installation)
-> (Value -> Parser [Installation])
-> Maybe Installation
-> FromJSON Installation
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Installation
parseJSON :: Value -> Parser Installation
$cparseJSONList :: Value -> Parser [Installation]
parseJSONList :: Value -> Parser [Installation]
$comittedField :: Maybe Installation
omittedField :: Maybe Installation
FromJSON)

data GetInstallationHttpError = GetInstallationHttpError
  { GetInstallationHttpError -> Status
status :: Status
  , GetInstallationHttpError -> ByteString
body :: BSL.ByteString
  }
  deriving stock (Int -> GetInstallationHttpError -> ShowS
[GetInstallationHttpError] -> ShowS
GetInstallationHttpError -> String
(Int -> GetInstallationHttpError -> ShowS)
-> (GetInstallationHttpError -> String)
-> ([GetInstallationHttpError] -> ShowS)
-> Show GetInstallationHttpError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GetInstallationHttpError -> ShowS
showsPrec :: Int -> GetInstallationHttpError -> ShowS
$cshow :: GetInstallationHttpError -> String
show :: GetInstallationHttpError -> String
$cshowList :: [GetInstallationHttpError] -> ShowS
showList :: [GetInstallationHttpError] -> ShowS
Show)
  deriving anyclass (Show GetInstallationHttpError
Typeable GetInstallationHttpError
(Typeable GetInstallationHttpError,
 Show GetInstallationHttpError) =>
(GetInstallationHttpError -> SomeException)
-> (SomeException -> Maybe GetInstallationHttpError)
-> (GetInstallationHttpError -> String)
-> Exception GetInstallationHttpError
SomeException -> Maybe GetInstallationHttpError
GetInstallationHttpError -> String
GetInstallationHttpError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: GetInstallationHttpError -> SomeException
toException :: GetInstallationHttpError -> SomeException
$cfromException :: SomeException -> Maybe GetInstallationHttpError
fromException :: SomeException -> Maybe GetInstallationHttpError
$cdisplayException :: GetInstallationHttpError -> String
displayException :: GetInstallationHttpError -> String
Exception)

data GetInstallationJsonDecodeError = GetInstallationJsonDecodeError
  { GetInstallationJsonDecodeError -> ByteString
body :: BSL.ByteString
  , GetInstallationJsonDecodeError -> String
message :: String
  }
  deriving stock (Int -> GetInstallationJsonDecodeError -> ShowS
[GetInstallationJsonDecodeError] -> ShowS
GetInstallationJsonDecodeError -> String
(Int -> GetInstallationJsonDecodeError -> ShowS)
-> (GetInstallationJsonDecodeError -> String)
-> ([GetInstallationJsonDecodeError] -> ShowS)
-> Show GetInstallationJsonDecodeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GetInstallationJsonDecodeError -> ShowS
showsPrec :: Int -> GetInstallationJsonDecodeError -> ShowS
$cshow :: GetInstallationJsonDecodeError -> String
show :: GetInstallationJsonDecodeError -> String
$cshowList :: [GetInstallationJsonDecodeError] -> ShowS
showList :: [GetInstallationJsonDecodeError] -> ShowS
Show)
  deriving anyclass (Show GetInstallationJsonDecodeError
Typeable GetInstallationJsonDecodeError
(Typeable GetInstallationJsonDecodeError,
 Show GetInstallationJsonDecodeError) =>
(GetInstallationJsonDecodeError -> SomeException)
-> (SomeException -> Maybe GetInstallationJsonDecodeError)
-> (GetInstallationJsonDecodeError -> String)
-> Exception GetInstallationJsonDecodeError
SomeException -> Maybe GetInstallationJsonDecodeError
GetInstallationJsonDecodeError -> String
GetInstallationJsonDecodeError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: GetInstallationJsonDecodeError -> SomeException
toException :: GetInstallationJsonDecodeError -> SomeException
$cfromException :: SomeException -> Maybe GetInstallationJsonDecodeError
fromException :: SomeException -> Maybe GetInstallationJsonDecodeError
$cdisplayException :: GetInstallationJsonDecodeError -> String
displayException :: GetInstallationJsonDecodeError -> String
Exception)

getInstallation :: MonadIO m => AppCredentials -> Text -> m Installation
getInstallation :: forall (m :: * -> *).
MonadIO m =>
AppCredentials -> Text -> m Installation
getInstallation AppCredentials
creds Text
prefix = do
  Request
req <- String -> m Request
forall (m :: * -> *). MonadIO m => String -> m Request
githubRequest (String -> m Request) -> String -> m Request
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/installation"
  (Status -> ByteString -> GetInstallationHttpError)
-> (ByteString -> String -> GetInstallationJsonDecodeError)
-> AppCredentials
-> Request
-> m Installation
forall (m :: * -> *) a e1 e2.
(MonadIO m, FromJSON a, Exception e1, Exception e2) =>
(Status -> ByteString -> e1)
-> (ByteString -> String -> e2) -> AppCredentials -> Request -> m a
appHttpJSON Status -> ByteString -> GetInstallationHttpError
GetInstallationHttpError ByteString -> String -> GetInstallationJsonDecodeError
GetInstallationJsonDecodeError AppCredentials
creds Request
req

githubRequest :: MonadIO m => String -> m Request
githubRequest :: forall (m :: * -> *). MonadIO m => String -> m Request
githubRequest =
  IO Request -> m Request
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    (IO Request -> m Request)
-> (String -> IO Request) -> String -> m Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest
    (String -> IO Request) -> ShowS -> String -> IO Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"https://api.github.com" <>)
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
ensureLeadingSlash

ensureLeadingSlash :: String -> String
ensureLeadingSlash :: ShowS
ensureLeadingSlash = \case
  x :: String
x@(Char
'/' : String
_) -> String
x
  String
x -> Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: String
x

appHttpJSON
  :: (MonadIO m, FromJSON a, Exception e1, Exception e2)
  => (Status -> BSL.ByteString -> e1)
  -- ^ Error for non-200
  -> (BSL.ByteString -> String -> e2)
  -- ^ Error for unexpected JSON
  -> AppCredentials
  -> Request
  -> m a
appHttpJSON :: forall (m :: * -> *) a e1 e2.
(MonadIO m, FromJSON a, Exception e1, Exception e2) =>
(Status -> ByteString -> e1)
-> (ByteString -> String -> e2) -> AppCredentials -> Request -> m a
appHttpJSON Status -> ByteString -> e1
onErrStatus ByteString -> String -> e2
onErrDecode AppCredentials
creds Request
req = do
  ByteString
jwt <- ExpirationTime -> Issuer -> PrivateKey -> m ByteString
forall (m :: * -> *).
MonadIO m =>
ExpirationTime -> Issuer -> PrivateKey -> m ByteString
signJWT ExpirationTime
expiration Issuer
issuer AppCredentials
creds.privateKey

  -- parse the response body ourselves, to improve error messages
  Response ByteString
resp <-
    Request -> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLBS
      (Request -> m (Response ByteString))
-> Request -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> Request -> Request
addRequestHeader HeaderName
hAccept ByteString
"application/vnd.github+json"
      (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> Request -> Request
addRequestHeader HeaderName
hAuthorization (ByteString
"Bearer " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
jwt)
      (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> Request -> Request
addRequestHeader HeaderName
hUserAgent ByteString
"github-app-token"
      (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> Request -> Request
addRequestHeader HeaderName
"X-GitHub-Api-Version" ByteString
"2022-11-28" Request
req

  let
    status :: Status
status = Response ByteString -> Status
forall a. Response a -> Status
getResponseStatus Response ByteString
resp
    body :: ByteString
body = Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody Response ByteString
resp

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Status -> Bool
statusIsSuccessful Status
status) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ e1 -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (e1 -> m ()) -> e1 -> m ()
forall a b. (a -> b) -> a -> b
$ Status -> ByteString -> e1
onErrStatus Status
status ByteString
body
  (String -> m a) -> (a -> m a) -> Either String a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (e2 -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (e2 -> m a) -> (String -> e2) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String -> e2
onErrDecode ByteString
body) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> m a) -> Either String a -> m a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
body
 where
  -- We're going to use it right away and only once, so 5m should be more than
  -- enough
  expiration :: ExpirationTime
expiration = NominalDiffTime -> ExpirationTime
ExpirationTime (NominalDiffTime -> ExpirationTime)
-> NominalDiffTime -> ExpirationTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
5 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
60
  issuer :: Issuer
issuer = Text -> Issuer
Issuer (Text -> Issuer) -> Text -> Issuer
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show AppCredentials
creds.appId.unwrap