d97b97c..master · github-app

git.iko.soy/github-app

on master help sign in

.gitignore+2−1

since splitsnapshots

unifiedsplit

@@ -3,4 +3,5 @@

3cabal.project.local

4cabal.project.local~

5.ghc.environment.*

6−*.cabal

7+.stack-work

README.md+25−1

@@ -1 +1,25 @@

1−# github-app

1+# Authenticate as a GitHub App

3+This library provides functions that help with authenticating as a [GitHub App][ghapp].

6+## Use

8+1. [Register][reg] your App with GitHub to obtain an App ID and a private key.

9+2. Using the data from the step above, create `AppAuth`.

10+3. For each installation of your app, get an `InstallationAuth` using `mkInstallationAuth`.

11+4. Use the `executeAppRequest` function to execute requests.

12+ Behind the scenes, this function exchanges the installation auth token for

13+ a regular access token, caches it, and renews as needed.

14+

15+See [serokell/github-ops-access][ghopsa] for a real-life example use.

16+

17+[ghapp]: https://developer.github.com/apps/

18+[reg]: https://github.com/settings/apps

19+[ghopsa]: https://github.com/serokell/github-ops-access/blob/test/webhook/Main.hs

20+

21+

22+## About Serokell

23+

24+This library is maintained and funded with ❤️ by [Serokell](https://serokell.io/).

25+The names and logo for Serokell are trademark of Serokell OÜ.

github-app.cabalnew file+74

@@ -0,0 +1,74 @@

1+cabal-version: 1.12

3+-- This file has been generated from package.yaml by hpack version 0.38.1.

4+--

5+-- see: https://github.com/sol/hpack

7+name: github-app

8+version: 0.0.1

9+synopsis: Authetnicate as a GitHub App

10+description: Please see the README on GitHub at <https://github.com/serokell/github-app#readme>

11+category: Network

12+homepage: https://github.com/serokell/github-app#readme

13+bug-reports: https://github.com/serokell/github-app/issues

14+author: Serokell

15+maintainer: Kirill Elagin <kirelagin@serokell.io>

16+copyright: 2018 Serokell

17+license: MPL-2.0

18+license-file: LICENSE

19+build-type: Simple

20+extra-source-files:

21+ README.md

22+ ChangeLog.md

23+

24+source-repository head

25+ type: git

26+ location: https://github.com/serokell/github-app

27+

28+library

29+ exposed-modules:

30+ Crypto.PubKey.RSA.Read

31+ GitHub.App.Auth

32+ GitHub.App.Request

33+ GitHub.Data.Apps

34+ GitHub.Data.Installations

35+ other-modules:

36+ Paths_github_app

37+ hs-source-dirs:

38+ src

39+ default-extensions:

40+ ApplicativeDo

41+ DeriveDataTypeable

42+ DeriveGeneric

43+ FlexibleContexts

44+ FlexibleInstances

45+ GeneralizedNewtypeDeriving

46+ LambdaCase

47+ MultiParamTypeClasses

48+ NamedFieldPuns

49+ OverloadedStrings

50+ RankNTypes

51+ RecordWildCards

52+ ScopedTypeVariables

53+ StandaloneDeriving

54+ TemplateHaskell

55+ TupleSections

56+ TypeApplications

57+ build-depends:

58+ aeson

59+ , base >=4.7 && <5

60+ , bytestring

61+ , cryptonite

62+ , github

63+ , http-client

64+ , http-client-tls

65+ , http-types

66+ , jwt >=0.8.0

67+ , mtl

68+ , safe-exceptions

69+ , tagged

70+ , text

71+ , time

72+ , x509

73+ , x509-store

74+ default-language: Haskell2010

package.yaml+6−2

@@ -15,6 +15,7 @@ extra-source-files:

16default-extensions:

17 - ApplicativeDo

18+ - DeriveDataTypeable

18 - DeriveGeneric

19 - DeriveGeneric

19 - FlexibleContexts

20 - FlexibleContexts

20 - FlexibleInstances

21 - FlexibleInstances

@@ -39,13 +40,16 @@ library:

39 dependencies:

40 dependencies:

40 - aeson

41 - aeson

41 - bytestring

42 - bytestring

42− - crypto-pubkey-types

43+ - cryptonite

43 - github

44 - github

44 - http-client

45 - http-client

45 - http-client-tls

46 - http-client-tls

46 - http-types

47 - http-types

47− - jwt

48+ - jwt >= 0.8.0

48 - mtl

49 - mtl

49 - safe-exceptions

50 - safe-exceptions

51+ - tagged

50 - text

52 - text

51 - time

53 - time

54+ - x509

55+ - x509-store

src/Crypto/PubKey/RSA/Read.hsnew file+27

@@ -0,0 +1,27 @@

1+{- This Source Code Form is subject to the terms of the Mozilla Public

2+ - License, v. 2.0. If a copy of the MPL was not distributed with this

3+ - file, You can obtain one at http://mozilla.org/MPL/2.0/.

4+ -}

6+module Crypto.PubKey.RSA.Read

7+ ( ReadRsaKeyError (..)

8+ , readRsaPem

9+ ) where

10+

11+import Crypto.PubKey.RSA (PrivateKey)

12+import Data.X509 (PrivKey (PrivKeyRSA))

13+import Data.ByteString (ByteString)

14+import Data.X509.Memory (readKeyFileFromMemory)

15+

16+

17+data ReadRsaKeyError

18+ = SingleKeyExpected { rrkeActualKeysCount :: Int }

19+ | NotRsaKey

20+

21+readRsaPem :: ByteString -> Either ReadRsaKeyError PrivateKey

22+readRsaPem bs =

23+ case readKeyFileFromMemory bs of

24+ [k] -> case k of

25+ PrivKeyRSA rsaKey -> Right rsaKey

26+ _ -> Left NotRsaKey

27+ l -> Left $ SingleKeyExpected (length l)

src/GitHub/App/Auth.hs+37−30

@@ -7,47 +7,48 @@

7{-# LANGUAGE DataKinds #-}

9module GitHub.App.Auth

10+ ( AppAuth (..)

11+

10− ( InstallationAuth

12+ , InstallationAuth

11 , mkInstallationAuth

13 , mkInstallationAuth

13 , obtainAccessToken

15 , obtainAccessToken

14−

15− , AppId

16− , InstallationId

17 ) where

16 ) where

19import Prelude hiding (exp)

18import Prelude hiding (exp)

21import Control.Concurrent (MVar, newMVar, putMVar, readMVar, takeMVar)

20import Control.Concurrent (MVar, newMVar, putMVar, readMVar, takeMVar)

22import Control.Exception.Safe (bracketOnError, catch)

21import Control.Exception.Safe (bracketOnError, catch)

23−import Control.Monad.Except (MonadError (throwError), ExceptT, runExceptT)

22+import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT)

24−import Data.Functor (($>))

23+import Control.Monad.Trans (lift)

25−import Crypto.Types.PubKey.RSA (PrivateKey)

24+import Crypto.PubKey.RSA (PrivateKey)

26import Data.Aeson (FromJSON (..), withObject, (.:))

25import Data.Aeson (FromJSON (..), withObject, (.:))

26+import qualified Data.ByteString.Lazy as LBS

27+import Data.Functor (($>))

27import Data.Maybe (fromMaybe)

28import Data.Maybe (fromMaybe)

28import Data.Semigroup ((<>))

29import Data.Semigroup ((<>))

30+import Data.Tagged

29import Data.Text (Text)

31import Data.Text (Text)

30import qualified Data.Text as T

32import qualified Data.Text as T

31import Data.Text.Encoding (encodeUtf8)

33import Data.Text.Encoding (encodeUtf8)

32import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)

34import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)

33import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)

35import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)

34−import Control.Monad.Trans (lift)

35−import Data.Word (Word64)

36import GitHub.Auth (Auth (OAuth))

37+import GitHub.Data.Apps (App)

37import GitHub.Data.Definitions (Error (HTTPError))

38import GitHub.Data.Definitions (Error (HTTPError))

38−import GitHub.Data.Request (StatusMap)

39+import GitHub.Data.Id (Id, untagId)

39−import GitHub.Request (parseResponse)

40+import GitHub.Data.Installations (Installation)

40−import Web.JWT (JWTClaimsSet (exp, iat, iss), Signer (RSAPrivateKey), encodeSigned,

41+import GitHub.Request (StatusMap, parseResponseJSON)

41− numericDate, stringOrURI)

42import Network.HTTP.Client as HTTP

43import qualified Network.HTTP.Client.Internal as HTTP

44import qualified Network.HTTP.Types as HTTP

45−import qualified Data.ByteString.Lazy as LBS

45+import Web.JWT (JWTClaimsSet (exp, iat, iss), Signer (RSAPrivateKey), encodeSigned, numericDate,

46+ stringOrURI)

48-- | JWT expiration time. Maximum accepted by GitHub is 10 minutes

49-- | JWT expiration time. Maximum accepted by GitHub is 10 minutes

49jwtExpTime :: NominalDiffTime

50jwtExpTime :: NominalDiffTime

50−jwtExpTime = 600

51+jwtExpTime = 300

52-- | Installation access token expiration time. It is fixed by GitHub and is equal to 1 hour

53-- | Installation access token expiration time. It is fixed by GitHub and is equal to 1 hour

53instKeyExpTime :: NominalDiffTime

54instKeyExpTime :: NominalDiffTime

@@ -64,10 +65,16 @@ baseUrl :: Text

64baseUrl = "https://api.github.com"

65baseUrl = "https://api.github.com"

68+-- | Credentials of a GitHub App

69+data AppAuth = AppAuth

70+ { aaAppId :: !(Id App)

71+ , aaPrivateKey :: !PrivateKey

72+ }

73+

67-- | Cached GitHub installation access token

74-- | Cached GitHub installation access token

68data InstallationToken = InstallationToken

75data InstallationToken = InstallationToken

69− { itToken :: Auth

76+ { itToken :: !Auth

70− , itExpirationTime :: UTCTime

77+ , itExpirationTime :: !UTCTime

71 } deriving (Show)

78 } deriving (Show)

73instance FromJSON InstallationToken where

80instance FromJSON InstallationToken where

@@ -77,7 +84,7 @@ instance FromJSON InstallationToken where

77 <*> o .: "expires_at"

84 <*> o .: "expires_at"

80−-- | Credentials required for an app to authenticate as an installation

87+-- | Credentials required for an App to authenticate as an installation

81data InstallationAuth = InstallationAuth

88data InstallationAuth = InstallationAuth

82 { iaClaimsSet :: !JWTClaimsSet -- ^ Prefilled claims set

89 { iaClaimsSet :: !JWTClaimsSet -- ^ Prefilled claims set

83 , iaAppPrivateKey :: !PrivateKey -- ^ Private key to sign token requests

90 , iaAppPrivateKey :: !PrivateKey -- ^ Private key to sign token requests

@@ -86,20 +93,16 @@ data InstallationAuth = InstallationAuth

86 }

93 }

89−type AppId = Word64

90−type InstallationId = Word64

91−

92-- | Smart constructor for 'InstallationAuth'

96-- | Smart constructor for 'InstallationAuth'

93mkInstallationAuth

97mkInstallationAuth

94− :: AppId -- ^ GitHub App ID

98+ :: AppAuth

95− -> PrivateKey -- ^ GitHub App Private Key

96− -> InstallationId -- ^ Installation ID

99+ -> Id Installation

97 -> IO InstallationAuth

100 -> IO InstallationAuth

98−mkInstallationAuth appId pk instId = do

101+mkInstallationAuth AppAuth{aaAppId, aaPrivateKey} instId = do

99 varToken <- newMVar Nothing

102 varToken <- newMVar Nothing

100− let issuer = fromMaybe (error "impossible") . stringOrURI . T.pack . show $ appId

103+ let issuer = fromMaybe (error "impossible") . stringOrURI . T.pack . show . untagId $ aaAppId

101 claimsSet = mempty { iss = Just issuer }

104 claimsSet = mempty { iss = Just issuer }

102− pure $ InstallationAuth claimsSet pk (T.pack . show $ instId) varToken

105+ pure $ InstallationAuth claimsSet aaPrivateKey (T.pack . show . untagId $ instId) varToken

103

106

104-- | Create a request which, when executed, will obtain a new access token

107-- | Create a request which, when executed, will obtain a new access token

105createAccessTokenR :: InstallationAuth -> IO HTTP.Request

108createAccessTokenR :: InstallationAuth -> IO HTTP.Request

@@ -110,11 +113,15 @@ createAccessTokenR InstallationAuth{..} = do

110 { iat = Just $ toJsonTime currentTime

113 { iat = Just $ toJsonTime currentTime

111 , exp = Just $ toJsonTime expiryTime

114 , exp = Just $ toJsonTime expiryTime

112 }

115 }

113− jwt = encodeSigned (RSAPrivateKey iaAppPrivateKey) claims

116+ jwt = encodeSigned (RSAPrivateKey iaAppPrivateKey) mempty claims

114

117

115 req <- HTTP.parseRequest . T.unpack $ url

118 req <- HTTP.parseRequest . T.unpack $ url

116 pure req

119 pure req

120+ { HTTP.requestHeaders =

117− { HTTP.requestHeaders = [("Authorization", "Bearer " <> encodeUtf8 jwt)]

121+ [ ("Authorization", "Bearer " <> encodeUtf8 jwt)

122+ , ("Accept", "application/vnd.github.machine-man-preview+json")

123+ , ("User-Agent", "github-app/Haskell")

124+ ]

118 , HTTP.checkResponse = successOrMissing Nothing

125 , HTTP.checkResponse = successOrMissing Nothing

119 , HTTP.method = "POST"

126 , HTTP.method = "POST"

120 }

127 }

@@ -141,7 +148,7 @@ obtainAccessToken mgr ia@InstallationAuth{..} = readMVar iaToken >>= \case

141 renew :: IO (Either Error Auth)

148 renew :: IO (Either Error Auth)

142 renew = bracketOnError (takeMVar iaToken) (putMVar iaToken) $ \_ -> do

149 renew = bracketOnError (takeMVar iaToken) (putMVar iaToken) $ \_ -> do

143 req <- createAccessTokenR ia

150 req <- createAccessTokenR ia

144− result <- runExceptT $ httpLbs' req >>= parseResponse

151+ result <- runExceptT $ httpLbs' req >>= parseResponseJSON

145 case result of

152 case result of

146 Right newToken -> putMVar iaToken (Just newToken) $> Right (itToken newToken)

153 Right newToken -> putMVar iaToken (Just newToken) $> Right (itToken newToken)

147 Left err -> putMVar iaToken Nothing $> Left err

154 Left err -> putMVar iaToken Nothing $> Left err

src/GitHub/App/Request.hs+4−2

@@ -10,6 +10,7 @@ module GitHub.App.Request

10 , executeAppRequestWithMgr

11 ) where

13+import Data.Aeson (FromJSON)

13import GitHub.Data (Error (..))

14import GitHub.Data (Error (..))

14import GitHub.Data.Request (Request)

15import GitHub.Data.Request (Request)

15import GitHub.Request (executeRequestWithMgr)

16import GitHub.Request (executeRequestWithMgr)

@@ -19,7 +20,7 @@ import Network.HTTP.Client.TLS (newTlsManager)

19import GitHub.App.Auth (InstallationAuth, obtainAccessToken)

20import GitHub.App.Auth (InstallationAuth, obtainAccessToken)

22−executeAppRequest :: InstallationAuth -> Request k a -> IO (Either Error a)

23+executeAppRequest :: FromJSON a => InstallationAuth -> Request k a -> IO (Either Error a)

23executeAppRequest instAuth req = do

24executeAppRequest instAuth req = do

24 manager <- newTlsManager

25 manager <- newTlsManager

25 x <- executeAppRequestWithMgr manager instAuth req

26 x <- executeAppRequestWithMgr manager instAuth req

@@ -29,7 +30,8 @@ executeAppRequest instAuth req = do

29 pure x

30 pure x

31executeAppRequestWithMgr

32executeAppRequestWithMgr

33+ :: FromJSON a

32− :: Manager

34+ => Manager

33 -> InstallationAuth

35 -> InstallationAuth

34 -> Request k a

36 -> Request k a

35 -> IO (Either Error a)

37 -> IO (Either Error a)

src/GitHub/Data/Apps.hsnew file+31

@@ -0,0 +1,31 @@

1+{- This Source Code Form is subject to the terms of the Mozilla Public

2+ - License, v. 2.0. If a copy of the MPL was not distributed with this

3+ - file, You can obtain one at http://mozilla.org/MPL/2.0/.

4+ -}

6+{-# LANGUAGE CPP #-}

8+module GitHub.Data.Apps where

10+import GitHub.Data.Definitions (SimpleOwner)

11+import GitHub.Data.Id (Id)

12+import GitHub.Data.Name (Name)

13+import GitHub.Data.URL (URL)

14+import GitHub.Internal.Prelude

15+import Prelude ()

16+

17+

18+data App = App

19+ { appId :: !(Id App)

20+ , appOwner :: !SimpleOwner

21+ , appName :: !(Name App)

22+ , appDescription :: !(Maybe Text)

23+ , appExternalUrl :: !URL

24+ , appHtmlUrl :: !URL

25+ , appCreatedAt :: !(Maybe UTCTime)

26+ , appUpdatedAt :: !(Maybe UTCTime)

27+ }

28+ deriving (Show, Data, Typeable, Eq, Ord, Generic)

29+

30+instance NFData App where rnf = genericRnf

31+instance Binary App

src/GitHub/Data/Installations.hsnew file+34

@@ -0,0 +1,34 @@

1+{- This Source Code Form is subject to the terms of the Mozilla Public

2+ - License, v. 2.0. If a copy of the MPL was not distributed with this

3+ - file, You can obtain one at http://mozilla.org/MPL/2.0/.

4+ -}

6+{-# LANGUAGE CPP #-}

8+module GitHub.Data.Installations where

10+import GitHub.Data.Apps (App)

11+import GitHub.Data.Id (Id)

12+import GitHub.Data.URL (URL)

13+import GitHub.Internal.Prelude

14+import Prelude ()

15+

16+

17+data Installation = Installation

18+ { installationId :: !(Id Installation)

19+-- , installationAccount

20+ , installationAccesssTokensUrl :: !URL

21+ , installationRepositoriesUrl :: !URL

22+ , installationHtmlUrl :: !URL

23+ , installationAppId :: (Id App)

24+-- , installationTargetId

25+-- , installationTargetType

26+-- , installationPermissions

27+-- , installationEvents

28+-- , installationSingleFileName

29+-- , installationRepositorySelection

30+ }

31+ deriving (Show, Data, Typeable, Eq, Ord, Generic)

32+

33+instance NFData Installation where rnf = genericRnf

34+instance Binary Installation

stack.yaml+5−3

@@ -1,9 +1,11 @@

1−resolver: lts-11.5

1+resolver: lts-14.19

3packages:

4- .

5# Dependency packages to be pulled from upstream that are not in the resolver

6# using the same syntax as the packages field.

7# (e.g., acme-missiles-0.3)

8−extra-deps:

8+extra-deps:

9+ - github-0.24

10+ - binary-instances-1

9− - jwt-0.8.0

11+ # - jwt-0.8.0

stack.yaml.locknew file+26

@@ -0,0 +1,26 @@

1+# This file was autogenerated by Stack.

2+# You should not edit this file by hand.

3+# For more information, please see the documentation at:

4+# https://docs.haskellstack.org/en/stable/topics/lock_files

6+packages:

7+- completed:

8+ hackage: github-0.24@sha256:4bf5a06289d36f78bf347b6a4f9906f659be7335cde78386a6c95568714a730b,6955

9+ pantry-tree:

10+ sha256: e0f84d7a3cdd76c6bd5395c8c72d24a1dda9616f857291820b08947c8290f042

11+ size: 7105

12+ original:

13+ hackage: github-0.24

14+- completed:

15+ hackage: binary-instances-1@sha256:b17565598b8df3241f9b46fa8e3a3368ecc8e3f2eb175d7c28f319042a6f5c79,2613

16+ pantry-tree:

17+ sha256: 938ffc6990cac12681c657f7afa93737eecf335e6f0212d8c0b7c1ea3e0f40f4

18+ size: 1035

19+ original:

20+ hackage: binary-instances-1

21+snapshots:

22+- completed:

23+ sha256: 9f79f6494473c9b46911364b94c4b5ef19ca8d35ebf62e46697cf651f198ee19

24+ size: 524155

25+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/19.yaml

26+ original: lts-14.19