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

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

    -- * Errors
  , InvalidPrivateKey (..)
  , InvalidDate (..)
  , InvalidIssuer (..)
  , AccessTokenHttpError (..)
  , AccessTokenJsonDecodeError (..)
  ) 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
  ( addRequestHeader
  , getResponseBody
  , getResponseStatus
  , httpLBS
  , parseRequest
  , setRequestBodyJSON
  )
import Network.HTTP.Types.Header (hAccept, hAuthorization, hUserAgent)
import Network.HTTP.Types.Status (Status, statusIsSuccessful)

newtype InstallationId = InstallationId
  { InstallationId -> Int
unwrap :: Int
  }

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

-- | <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
  ByteString
jwt <- ExpirationTime -> Issuer -> PrivateKey -> m ByteString
forall (m :: * -> *).
MonadIO m =>
ExpirationTime -> Issuer -> PrivateKey -> m ByteString
signJWT ExpirationTime
expiration Issuer
issuer AppCredentials
creds.privateKey

  Request
req <-
    IO Request -> m Request
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO Request -> m Request) -> IO Request -> m Request
forall a b. (a -> b) -> a -> b
$ String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest
      (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ String
"POST https://api.github.com/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

  -- 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 -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request -> Request
setBody 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
$ AccessTokenHttpError -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO
    (AccessTokenHttpError -> m ()) -> AccessTokenHttpError -> m ()
forall a b. (a -> b) -> a -> b
$ AccessTokenHttpError {Status
$sel:status:AccessTokenHttpError :: Status
status :: Status
status, ByteString
$sel:body:AccessTokenHttpError :: ByteString
body :: ByteString
body}

  (String -> m AccessToken)
-> (AccessToken -> m AccessToken)
-> Either String AccessToken
-> m AccessToken
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (AccessTokenJsonDecodeError -> m AccessToken
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (AccessTokenJsonDecodeError -> m AccessToken)
-> (String -> AccessTokenJsonDecodeError)
-> String
-> m AccessToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String -> AccessTokenJsonDecodeError
AccessTokenJsonDecodeError ByteString
body) AccessToken -> m AccessToken
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String AccessToken -> m AccessToken)
-> Either String AccessToken -> m AccessToken
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String AccessToken
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