github-app-token (empty) → 0.0.0.1

raw patch · 10 files changed

+484/−0 lines, 10 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, directory, dotenv, github-app-token, http-conduit, http-types, jwt, lens, lens-aeson, markdown-unlit, path, text, time, unliftio

Files

CHANGELOG.md +5/−0
LICENSE +21/−0
README.lhs +69/−0
README.md +69/−0
github-app-token.cabal +96/−0
src/GitHub/App/Token.hs +11/−0
src/GitHub/App/Token/AppCredentials.hs +17/−0
src/GitHub/App/Token/Generate.hs +91/−0
src/GitHub/App/Token/JWT.hs +91/−0
src/GitHub/App/Token/Prelude.hs +14/−0

+ CHANGELOG.md view

@@ -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.

+ LICENSE view

@@ -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.

+ README.lhs view

@@ -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+module Main (module Main) where++import Configuration.Dotenv qualified as Dotenv+import Control.Monad (when)+import System.Directory (doesFileExist)+import Text.Markdown.Unlit ()+```+-->++```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"+```++<!--+```haskell+main :: IO ()+main = do+  isLocal <- doesFileExist ".env"+  when isLocal $ Dotenv.loadFile Dotenv.defaultConfig+  example+```+-->++---++[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE)

+ README.md view

@@ -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+module Main (module Main) where++import Configuration.Dotenv qualified as Dotenv+import Control.Monad (when)+import System.Directory (doesFileExist)+import Text.Markdown.Unlit ()+```+-->++```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"+```++<!--+```haskell+main :: IO ()+main = do+  isLocal <- doesFileExist ".env"+  when isLocal $ Dotenv.loadFile Dotenv.defaultConfig+  example+```+-->++---++[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE)

+ github-app-token.cabal view

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

+ src/GitHub/App/Token.hs view

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

+ src/GitHub/App/Token/AppCredentials.hs view

@@ -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+  }

+ src/GitHub/App/Token/Generate.hs view

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

+ src/GitHub/App/Token/JWT.hs view

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

+ src/GitHub/App/Token/Prelude.hs view

@@ -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)