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

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

import GitHub.App.Token.Prelude

import Data.Aeson (FromJSON, eitherDecode)
import Data.ByteString.Lazy qualified as BSL
import GitHub.App.Token.AppCredentials
import GitHub.App.Token.JWT
import Network.HTTP.Simple
  ( addRequestHeader
  , getResponseBody
  , getResponseStatus
  , httpLBS
  , parseRequest
  )
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)

generateInstallationToken
  :: MonadIO m
  => AppCredentials
  -> InstallationId
  -> m AccessToken
generateInstallationToken :: forall (m :: * -> *).
MonadIO m =>
AppCredentials -> InstallationId -> m AccessToken
generateInstallationToken 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"

  -- 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
$ 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