diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +## [_Unreleased_](https://github.com/freckle/github-app-token/compare/v0.0.0.1...main) + +## [v0.0.0.1](https://github.com/freckle/github-app-token/tree/v0.0.0.1) + +First tagged pre-release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2024 Renaissance Learning Inc + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,69 @@ +# GitHub App Token + +[![Hackage](https://img.shields.io/hackage/v/github-app-token.svg?style=flat)](https://hackage.haskell.org/package/github-app-token) +[![Stackage Nightly](http://stackage.org/package/github-app-token/badge/nightly)](http://stackage.org/nightly/package/github-app-token) +[![Stackage LTS](http://stackage.org/package/github-app-token/badge/lts)](http://stackage.org/lts/package/github-app-token) +[![CI](https://github.com/freckle/github-app-token/actions/workflows/ci.yml/badge.svg)](https://github.com/freckle/github-app-token/actions/workflows/ci.yml) + +[Generate an installation access token for a GitHub App][docs] + +[docs]: https://docs.github.com/en/apps/creating-github-apps/authenticating-with-a-github-app/authenticating-as-a-github-app-installation + +## Usage + + + +```haskell +import Prelude + +import Control.Lens ((^?)) +import Data.Aeson.Lens +import Data.ByteString.Char8 qualified as BS8 +import Data.Text.Encoding (encodeUtf8) +import GitHub.App.Token +import Network.HTTP.Simple +import Network.HTTP.Types.Header (hAccept, hAuthorization, hUserAgent) +import System.Environment + +example :: IO () +example = do + appId <- AppId . read <$> getEnv "GITHUB_APP_ID" + privateKey <- PrivateKey . BS8.pack <$> getEnv "GITHUB_PRIVATE_KEY" + installationId <- InstallationId . read <$> getEnv "GITHUB_INSTALLATION_ID" + + let creds = AppCredentials {appId, privateKey} + token <- generateInstallationToken creds installationId + + req <- parseRequest "https://api.github.com/repos/freckle/github-app-token" + resp <- httpLBS + $ addRequestHeader hAccept "application/json" + $ addRequestHeader hAuthorization ("Bearer " <> encodeUtf8 token.token) + $ addRequestHeader hUserAgent "github-app-token/example" + $ req + + print $ getResponseBody resp ^? key "description" . _String + -- => Just "Generate an installation token for a GitHub App" +``` + + + +--- + +[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,69 @@ +# GitHub App Token + +[![Hackage](https://img.shields.io/hackage/v/github-app-token.svg?style=flat)](https://hackage.haskell.org/package/github-app-token) +[![Stackage Nightly](http://stackage.org/package/github-app-token/badge/nightly)](http://stackage.org/nightly/package/github-app-token) +[![Stackage LTS](http://stackage.org/package/github-app-token/badge/lts)](http://stackage.org/lts/package/github-app-token) +[![CI](https://github.com/freckle/github-app-token/actions/workflows/ci.yml/badge.svg)](https://github.com/freckle/github-app-token/actions/workflows/ci.yml) + +[Generate an installation access token for a GitHub App][docs] + +[docs]: https://docs.github.com/en/apps/creating-github-apps/authenticating-with-a-github-app/authenticating-as-a-github-app-installation + +## Usage + + + +```haskell +import Prelude + +import Control.Lens ((^?)) +import Data.Aeson.Lens +import Data.ByteString.Char8 qualified as BS8 +import Data.Text.Encoding (encodeUtf8) +import GitHub.App.Token +import Network.HTTP.Simple +import Network.HTTP.Types.Header (hAccept, hAuthorization, hUserAgent) +import System.Environment + +example :: IO () +example = do + appId <- AppId . read <$> getEnv "GITHUB_APP_ID" + privateKey <- PrivateKey . BS8.pack <$> getEnv "GITHUB_PRIVATE_KEY" + installationId <- InstallationId . read <$> getEnv "GITHUB_INSTALLATION_ID" + + let creds = AppCredentials {appId, privateKey} + token <- generateInstallationToken creds installationId + + req <- parseRequest "https://api.github.com/repos/freckle/github-app-token" + resp <- httpLBS + $ addRequestHeader hAccept "application/json" + $ addRequestHeader hAuthorization ("Bearer " <> encodeUtf8 token.token) + $ addRequestHeader hUserAgent "github-app-token/example" + $ req + + print $ getResponseBody resp ^? key "description" . _String + -- => Just "Generate an installation token for a GitHub App" +``` + + + +--- + +[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE) diff --git a/github-app-token.cabal b/github-app-token.cabal new file mode 100644 --- /dev/null +++ b/github-app-token.cabal @@ -0,0 +1,96 @@ +cabal-version: 1.18 +name: github-app-token +version: 0.0.0.1 +license: MIT +license-file: LICENSE +maintainer: Freckle Education +homepage: https://github.com/freckle/github-app-token#readme +bug-reports: https://github.com/freckle/github-app-token/issues +synopsis: Generate an installation access token for a GitHub App +description: Please see README.md +category: HTTP +build-type: Simple +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/freckle/github-app-token + +library + exposed-modules: + GitHub.App.Token + GitHub.App.Token.AppCredentials + GitHub.App.Token.Generate + GitHub.App.Token.JWT + GitHub.App.Token.Prelude + + hs-source-dirs: src + other-modules: Paths_github_app_token + default-language: GHC2021 + default-extensions: + DataKinds DeriveAnyClass DerivingVia DerivingStrategies + DuplicateRecordFields GADTs LambdaCase NoImplicitPrelude + NoMonomorphismRestriction OverloadedRecordDot OverloadedStrings + RecordWildCards TypeFamilies + + ghc-options: + -fignore-optim-changes -fwrite-ide-info -Weverything + -Wno-all-missed-specialisations -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-kind-signatures + -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode + -Wno-monomorphism-restriction -Wno-prepositive-qualified-module + -Wno-safe -Wno-unsafe + + build-depends: + aeson >=2.0.3.0, + base >=4.16.4.0 && <5, + bytestring >=0.11.4.0, + http-conduit >=2.3.8.1, + http-types >=0.12.3, + jwt >=0.11.0, + path >=0.9.2, + text >=1.2.5.0, + time >=1.11.1.1, + unliftio >=0.2.25.0 + + if impl(ghc >=9.8) + ghc-options: + -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures + +test-suite readme + type: exitcode-stdio-1.0 + main-is: README.lhs + other-modules: Paths_github_app_token + default-language: GHC2021 + default-extensions: + DataKinds DeriveAnyClass DerivingVia DerivingStrategies + DuplicateRecordFields GADTs LambdaCase NoImplicitPrelude + NoMonomorphismRestriction OverloadedRecordDot OverloadedStrings + RecordWildCards TypeFamilies + + ghc-options: + -fignore-optim-changes -fwrite-ide-info -Weverything + -Wno-all-missed-specialisations -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-kind-signatures + -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode + -Wno-monomorphism-restriction -Wno-prepositive-qualified-module + -Wno-safe -Wno-unsafe -pgmL markdown-unlit + + build-depends: + base >=4.16.4.0 && <5, + bytestring >=0.11.4.0, + directory >=1.3.6.2, + dotenv >=0.10.0.0, + github-app-token, + http-conduit >=2.3.8.1, + http-types >=0.12.3, + lens >=5.1.1, + lens-aeson >=1.2.2, + markdown-unlit >=0.5.1, + text >=1.2.5.0 + + if impl(ghc >=9.8) + ghc-options: + -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures diff --git a/src/GitHub/App/Token.hs b/src/GitHub/App/Token.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/App/Token.hs @@ -0,0 +1,11 @@ +module GitHub.App.Token + ( generateInstallationToken + , AppCredentials (..) + , AppId (..) + , PrivateKey (..) + , InstallationId (..) + , AccessToken (..) + ) where + +import GitHub.App.Token.AppCredentials +import GitHub.App.Token.Generate diff --git a/src/GitHub/App/Token/AppCredentials.hs b/src/GitHub/App/Token/AppCredentials.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/App/Token/AppCredentials.hs @@ -0,0 +1,17 @@ +module GitHub.App.Token.AppCredentials + ( AppCredentials (..) + , AppId (..) + , PrivateKey (..) + ) where + +import GitHub.App.Token.JWT (PrivateKey (..)) +import GitHub.App.Token.Prelude + +data AppCredentials = AppCredentials + { appId :: AppId + , privateKey :: PrivateKey + } + +newtype AppId = AppId + { unwrap :: Int + } diff --git a/src/GitHub/App/Token/Generate.hs b/src/GitHub/App/Token/Generate.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/App/Token/Generate.hs @@ -0,0 +1,91 @@ +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 + { unwrap :: Int + } + +data AccessToken = AccessToken + { token :: Text + , expires_at :: UTCTime + } + deriving stock (Show, Generic) + deriving anyclass (FromJSON) + +data AccessTokenHttpError = AccessTokenHttpError + { status :: Status + , body :: BSL.ByteString + } + deriving stock (Show) + deriving anyclass (Exception) + +data AccessTokenJsonDecodeError = AccessTokenJsonDecodeError + { body :: BSL.ByteString + , message :: String + } + deriving stock (Show) + deriving anyclass (Exception) + +generateInstallationToken + :: MonadIO m + => AppCredentials + -> InstallationId + -> m AccessToken +generateInstallationToken creds installationId = do + jwt <- signJWT expiration issuer creds.privateKey + + req <- + liftIO + $ parseRequest + $ "POST https://api.github.com/app/installations/" + <> show installationId.unwrap + <> "/access_tokens" + + -- parse the response body ourselves, to improve error messages + resp <- + httpLBS + $ addRequestHeader hAccept "application/vnd.github+json" + $ addRequestHeader hAuthorization ("Bearer " <> jwt) + $ addRequestHeader hUserAgent "github-app-token" + $ addRequestHeader "X-GitHub-Api-Version" "2022-11-28" req + + let + status = getResponseStatus resp + body = getResponseBody resp + + unless (statusIsSuccessful status) + $ throwIO + $ AccessTokenHttpError {status, body} + + either (throwIO . AccessTokenJsonDecodeError body) pure $ eitherDecode body + where + -- We're going to use it right away and only once, so 5m should be more than + -- enough + expiration = ExpirationTime $ 5 * 60 + issuer = Issuer $ pack $ show creds.appId.unwrap diff --git a/src/GitHub/App/Token/JWT.hs b/src/GitHub/App/Token/JWT.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/App/Token/JWT.hs @@ -0,0 +1,91 @@ +module GitHub.App.Token.JWT + ( signJWT + , ExpirationTime (..) + , Issuer (..) + + -- * Private RSA Key data + , PrivateKey (..) + + -- * Errors + , InvalidPrivateKey (..) + , InvalidDate (..) + , InvalidIssuer (..) + ) where + +import GitHub.App.Token.Prelude + +import Data.Text.Encoding (encodeUtf8) +import Data.Time (NominalDiffTime, addUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Web.JWT qualified as JWT + +newtype ExpirationTime = ExpirationTime + { unwrap :: NominalDiffTime + } + +newtype Issuer = Issuer + { unwrap :: Text + } + deriving stock (Show) + +newtype PrivateKey = PrivateKey + { unwrap :: ByteString + } + deriving stock (Show) + +newtype InvalidPrivateKey = InvalidPrivateKey PrivateKey + deriving stock (Show) + deriving anyclass (Exception) + +data InvalidDate = InvalidDate + { field :: String + , date :: UTCTime + } + deriving stock (Show) + deriving anyclass (Exception) + +newtype InvalidIssuer = InvalidIssuer Issuer + deriving stock (Show) + deriving anyclass (Exception) + +signJWT + :: MonadIO m + => ExpirationTime + -> Issuer + -> PrivateKey + -> m ByteString +signJWT expirationTime issuer privateKey = liftIO $ do + now <- getCurrentTime + let expiration = addUTCTime expirationTime.unwrap now + + signer <- + maybe + (throwIO $ InvalidPrivateKey privateKey) + (pure . JWT.EncodeRSAPrivateKey) + $ JWT.readRsaSecret privateKey.unwrap + + iat <- + maybe (throwIO $ InvalidDate "iat" now) pure + $ numericDate now + + exp <- + maybe (throwIO $ InvalidDate "exp" expiration) pure + $ numericDate expiration + + iss <- + maybe (throwIO $ InvalidIssuer issuer) pure + $ JWT.stringOrURI issuer.unwrap + + pure + $ encodeUtf8 + $ JWT.encodeSigned + signer + mempty {JWT.alg = Just JWT.RS256} + mempty + { JWT.iat = Just iat + , JWT.exp = Just exp + , JWT.iss = Just iss + } + +numericDate :: UTCTime -> Maybe JWT.NumericDate +numericDate = JWT.numericDate . utcTimeToPOSIXSeconds diff --git a/src/GitHub/App/Token/Prelude.hs b/src/GitHub/App/Token/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/App/Token/Prelude.hs @@ -0,0 +1,14 @@ +module GitHub.App.Token.Prelude + ( module X + ) where + +import Prelude as X hiding (exp) + +import Control.Monad as X (unless, when) +import Control.Monad.IO.Class as X (MonadIO (..)) +import Data.ByteString as X (ByteString) +import Data.Text as X (Text, pack, unpack) +import Data.Time as X (UTCTime) +import GHC.Generics as X (Generic) +import Path as X (Abs, Dir, File, Path, Rel, toFilePath) +import UnliftIO.Exception as X (Exception, throwIO)