git.iko.soy/github-app
on master help sign in
Merge pull request #3 from serokell/kirelagin/request
754597fKirill Elagin
package.yaml+11−4
compare with master
unifiedsplit
@@ -15,6 +15,7 @@ extra-source-files:
15
15
16default-extensions:
16default-extensions:
17 - ApplicativeDo
17 - ApplicativeDo
18+ - DeriveDataTypeable
18 - DeriveGeneric
19 - DeriveGeneric
19 - FlexibleContexts
20 - FlexibleContexts
20 - FlexibleInstances
21 - FlexibleInstances
@@ -24,6 +25,7 @@ default-extensions:
24 - NamedFieldPuns
25 - NamedFieldPuns
25 - OverloadedStrings
26 - OverloadedStrings
26 - RankNTypes
27 - RankNTypes
28+ - RecordWildCards
27 - ScopedTypeVariables
29 - ScopedTypeVariables
28 - StandaloneDeriving
30 - StandaloneDeriving
29 - TemplateHaskell
31 - TemplateHaskell
@@ -38,10 +40,15 @@ library:
38 dependencies:
40 dependencies:
39 - aeson
41 - aeson
40 - bytestring
42 - bytestring
41− - crypto-pubkey-types
43+ - cryptonite
42− - data-default-class
43 - github
44 - github
45+ - http-client
46+ - http-client-tls
47+ - http-types
44− - jwt
48+ - jwt >= 0.8.0
45− - req
49+ - mtl
50+ - safe-exceptions
46 - text
51 - text
47 - time
52 - time
53+ - x509
54+ - 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+ -}
5+
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.hsdeleted−131
@@ -1,131 +0,0 @@
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− -}
5−
6−module GitHub.App
7− ( InstallationAuth
8− , mkInstallationAuth
9−
10− , authenticateInstallation
11− ) where
12−
13−import Prelude hiding (exp)
14−
15−import Control.Concurrent (MVar, newEmptyMVar, putMVar, readMVar, takeMVar)
16−import Control.Monad (void)
17−import Crypto.Types.PubKey.RSA (PrivateKey (..))
18−import Data.Aeson (FromJSON (..), withObject, (.:))
19−import Data.ByteString (ByteString)
20−import Data.Default.Class (def)
21−import Data.Semigroup ((<>))
22−import Data.Text (Text)
23−import qualified Data.Text as T
24−import Data.Text.Encoding (encodeUtf8)
25−import Data.Time (NominalDiffTime, UTCTime, addUTCTime, defaultTimeLocale, diffUTCTime,
26− getCurrentTime, iso8601DateFormat, parseTimeM)
27−import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
28−import GitHub.Auth (Auth (..))
29−import Network.HTTP.Req (NoReqBody (..), Option, POST (..), Url, header, https, jsonResponse, req,
30− responseBody, runReq, (/:))
31−import Web.JWT (JSON, JWTClaimsSet (..), Signer (..), encodeSigned, numericDate, stringOrURI)
32−
33−
34−-- | JWT expiration time. Maximum accepted by GitHub is 10 minutes
35−jwtExpTime :: NominalDiffTime
36−jwtExpTime = 600
37−
38−-- | Installation access token expiration time. It is fixed by GitHub and is equal to 1 hour
39−instKeyExpTime :: NominalDiffTime
40−instKeyExpTime = 3600
41−
42−-- | When to renew the installation access token
43−--
44−-- We renew the access token when it is valid for less than 'bufferTime'
45−-- just to be on the safe side.
46−bufferTime :: NominalDiffTime
47−bufferTime = instKeyExpTime * 0.25
48−
49−
50−-- | Base URL of the GitHub API
51−baseURL :: Text
52−baseURL = "api.github.com"
53−
54−
55−type InstallationId = Text
56−
57−
58−-- | GitHub installation access token
59−data InstallationToken = InstallationToken
60− { itToken :: ByteString
61− , itExpirationTime :: UTCTime
62− } deriving (Show)
63−
64−instance FromJSON InstallationToken where
65− parseJSON = withObject "installation token" $ \o -> InstallationToken
66− <$> (encodeUtf8 <$> o .: "token")
67− <*> (either fail pure =<< parseExpiresAt <$> o .: "expires_at")
68− where
69− parseExpiresAt :: String -> Either String UTCTime
70− parseExpiresAt = parseTimeM True defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%SZ"))
71−
72−-- | Credentials required for an app to authenticate as an installation
73−data InstallationAuth = InstallationAuth
74− { iaAppId :: !Int -- ^ Application id
75− , iaAppPrivateKey :: !PrivateKey -- ^ Private key to sign token requests
76− , iaInstallationId :: !Text -- ^ Installation id
77− , iaToken :: !(MVar InstallationToken) -- ^ Installation Auth token
78− }
79−
80−-- | Return a valid App access token
81−--
82−-- Checks if the cached token is expired and renews it if needed.
83−authenticateInstallation :: InstallationAuth -> IO Auth
84−authenticateInstallation ia@InstallationAuth{iaToken} = do
85− InstallationToken{itToken, itExpirationTime} <- readMVar iaToken
86− currentTime <- getCurrentTime
87− if itExpirationTime `diffUTCTime` currentTime >= bufferTime
88− then return $ OAuth itToken
89− else do
90− void $ takeMVar iaToken
91− renewInstAuthToken ia
92− InstallationToken{itToken = newToken} <- readMVar iaToken
93− return $ OAuth newToken
94−
95−-- | Smart constructor for 'InstallationAuth'
96−mkInstallationAuth :: Int -> PrivateKey -> InstallationId -> IO InstallationAuth
97−mkInstallationAuth applicationId key instId = do
98− tokenVar <- newEmptyMVar
99− let instAuth = InstallationAuth applicationId key instId tokenVar
100− renewInstAuthToken instAuth
101− return instAuth
102−
103−-- | Get a new token from GitHub and cache it in 'InstallationAuth'
104−--
105−-- Assumes that the MVar in 'InstallationAuth' is empty. Otherwise will block.
106−renewInstAuthToken :: InstallationAuth -> IO ()
107−renewInstAuthToken InstallationAuth{iaAppId, iaInstallationId, iaAppPrivateKey, iaToken} = do
108− time <- getCurrentTime
109− let jwt = makeJWT time
110− t <- request (https baseURL /: "installations" /: iaInstallationId /: "access_tokens") mempty jwt
111− putMVar iaToken t
112− where
113− -- | Create a JSON Web Token for the given application id using application's private key
114− makeJWT :: UTCTime -> JSON
115− makeJWT currentTime =
116− let currDate = numericDate . utcTimeToPOSIXSeconds $ currentTime
117− expDate = numericDate . utcTimeToPOSIXSeconds $ jwtExpTime `addUTCTime` currentTime
118− issuer = stringOrURI . T.pack . show $ iaAppId
119− jwtClaimsSet = mempty {iss = issuer, iat = currDate, exp = expDate}
120− in encodeSigned (RSAPrivateKey iaAppPrivateKey) jwtClaimsSet
121−
122− -- | Make a request to GitHub to get an installation Auth token
123− request :: FromJSON m => Url scheme -> Option scheme -> JSON -> IO m
124− request url opts jwt = runReq def $ responseBody <$>
125− req POST url NoReqBody
126− jsonResponse -- specify how to interpret response
127− ( header "Authorization" ("Bearer " <> encodeUtf8 jwt)
128− <> header "Accept" "application/vnd.github.machine-man-preview+json"
129− <> header "user-agent" "Haskell/github-app (Haskell/req)"
130− <> opts
131− )
src/GitHub/App/Auth.hsnew file+187
@@ -0,0 +1,187 @@
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+ -}
5+
6+{-# LANGUAGE CPP #-}
7+{-# LANGUAGE DataKinds #-}
8+
9+module GitHub.App.Auth
10+ ( AppAuth (..)
11+
12+ , InstallationAuth
13+ , mkInstallationAuth
14+
15+ , obtainAccessToken
16+ ) where
17+
18+import Prelude hiding (exp)
19+
20+import Control.Concurrent (MVar, newMVar, putMVar, readMVar, takeMVar)
21+import Control.Exception.Safe (bracketOnError, catch)
22+import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT)
23+import Control.Monad.Trans (lift)
24+import Crypto.PubKey.RSA (PrivateKey)
25+import Data.Aeson (FromJSON (..), withObject, (.:))
26+import qualified Data.ByteString.Lazy as LBS
27+import Data.Functor (($>))
28+import Data.Maybe (fromMaybe)
29+import Data.Semigroup ((<>))
30+import Data.Text (Text)
31+import qualified Data.Text as T
32+import Data.Text.Encoding (encodeUtf8)
33+import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
34+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
35+import GitHub.Auth (Auth (OAuth))
36+import GitHub.Data.Apps (App)
37+import GitHub.Data.Definitions (Error (HTTPError))
38+import GitHub.Data.Id (Id, untagId)
39+import GitHub.Data.Installations (Installation)
40+import GitHub.Data.Request (StatusMap)
41+import GitHub.Request (parseResponse)
42+import Network.HTTP.Client as HTTP
43+import qualified Network.HTTP.Client.Internal as HTTP
44+import qualified Network.HTTP.Types as HTTP
45+import Web.JWT (JWTClaimsSet (exp, iat, iss), Signer (RSAPrivateKey), encodeSigned, numericDate,
46+ stringOrURI)
47+
48+
49+-- | JWT expiration time. Maximum accepted by GitHub is 10 minutes
50+jwtExpTime :: NominalDiffTime
51+jwtExpTime = 600
52+
53+-- | Installation access token expiration time. It is fixed by GitHub and is equal to 1 hour
54+instKeyExpTime :: NominalDiffTime
55+instKeyExpTime = 3600
56+
57+-- | When to renew the installation access token
58+--
59+-- We renew the access token when it is valid for less than 'bufferTime'
60+-- just to be on the safe side.
61+bufferTime :: NominalDiffTime
62+bufferTime = instKeyExpTime * 0.25
63+
64+baseUrl :: Text
65+baseUrl = "https://api.github.com"
66+
67+
68+-- | Credentials of a GitHub App
69+data AppAuth = AppAuth
70+ { aaAppId :: !(Id App)
71+ , aaPrivateKey :: !PrivateKey
72+ }
73+
74+-- | Cached GitHub installation access token
75+data InstallationToken = InstallationToken
76+ { itToken :: !Auth
77+ , itExpirationTime :: !UTCTime
78+ } deriving (Show)
79+
80+instance FromJSON InstallationToken where
81+ parseJSON = withObject "Installation access token" $ \o ->
82+ InstallationToken
83+ <$> (OAuth . encodeUtf8 <$> o .: "token")
84+ <*> o .: "expires_at"
85+
86+
87+-- | Credentials required for an App to authenticate as an installation
88+data InstallationAuth = InstallationAuth
89+ { iaClaimsSet :: !JWTClaimsSet -- ^ Prefilled claims set
90+ , iaAppPrivateKey :: !PrivateKey -- ^ Private key to sign token requests
91+ , iaInstallationId :: !Text -- ^ Installation id
92+ , iaToken :: !(MVar (Maybe InstallationToken)) -- ^ Installation Auth token
93+ }
94+
95+
96+-- | Smart constructor for 'InstallationAuth'
97+mkInstallationAuth
98+ :: AppAuth
99+ -> Id Installation
100+ -> IO InstallationAuth
101+mkInstallationAuth AppAuth{aaAppId, aaPrivateKey} instId = do
102+ varToken <- newMVar Nothing
103+ let issuer = fromMaybe (error "impossible") . stringOrURI . T.pack . show . untagId $ aaAppId
104+ claimsSet = mempty { iss = Just issuer }
105+ pure $ InstallationAuth claimsSet aaPrivateKey (T.pack . show . untagId $ instId) varToken
106+
107+-- | Create a request which, when executed, will obtain a new access token
108+createAccessTokenR :: InstallationAuth -> IO HTTP.Request
109+createAccessTokenR InstallationAuth{..} = do
110+ currentTime <- utcTimeToPOSIXSeconds <$> getCurrentTime
111+ let expiryTime = currentTime + jwtExpTime
112+ claims = iaClaimsSet
113+ { iat = Just $ toJsonTime currentTime
114+ , exp = Just $ toJsonTime expiryTime
115+ }
116+ jwt = encodeSigned (RSAPrivateKey iaAppPrivateKey) claims
117+
118+ req <- HTTP.parseRequest . T.unpack $ url
119+ pure req
120+ { HTTP.requestHeaders =
121+ [ ("Authorization", "Bearer " <> encodeUtf8 jwt)
122+ , ("Accept", "application/vnd.github.machine-man-preview+json")
123+ , ("User-Agent", "github-app/Haskell")
124+ ]
125+ , HTTP.checkResponse = successOrMissing Nothing
126+ , HTTP.method = "POST"
127+ }
128+ where
129+ toJsonTime = fromMaybe (error "impossible") . numericDate
130+ url = baseUrl <> "/installations/" <> iaInstallationId <> "/access_tokens"
131+
132+-- | Get a valid access token
133+--
134+-- Tries to use the cached one. If it is invalid, requests a new one
135+-- and caches it for future use.
136+obtainAccessToken
137+ :: Manager
138+ -> InstallationAuth
139+ -> IO (Either Error Auth)
140+obtainAccessToken mgr ia@InstallationAuth{..} = readMVar iaToken >>= \case
141+ Nothing -> renew
142+ Just InstallationToken{itToken, itExpirationTime} -> do
143+ currentTime <- getCurrentTime
144+ if itExpirationTime `diffUTCTime` currentTime < bufferTime
145+ then renew
146+ else pure $ Right itToken
147+ where
148+ renew :: IO (Either Error Auth)
149+ renew = bracketOnError (takeMVar iaToken) (putMVar iaToken) $ \_ -> do
150+ req <- createAccessTokenR ia
151+ result <- runExceptT $ httpLbs' req >>= parseResponse
152+ case result of
153+ Right newToken -> putMVar iaToken (Just newToken) $> Right (itToken newToken)
154+ Left err -> putMVar iaToken Nothing $> Left err
155+
156+ httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString)
157+ httpLbs' req' = lift (httpLbs req' mgr) `catch` onHttpException
158+
159+
160+
161+---------------------------------------
162+-- Copy-pasted from the github package
163+---------------------------------------
164+
165+#if MIN_VERSION_http_client(0,5,0)
166+successOrMissing :: Maybe (StatusMap a) -> HTTP.Request -> HTTP.Response HTTP.BodyReader -> IO ()
167+successOrMissing sm _req res
168+ | check = pure ()
169+ | otherwise = do
170+ chunk <- HTTP.brReadSome (HTTP.responseBody res) 1024
171+ let res' = fmap (const ()) res
172+ HTTP.throwHttp $ HTTP.StatusCodeException res' (LBS.toStrict chunk)
173+ where
174+ HTTP.Status sci _ = HTTP.responseStatus res
175+#else
176+successOrMissing :: Maybe (StatusMap a) -> Status -> ResponseHeaders -> HTTP.CookieJar -> Maybe E.SomeException
177+successOrMissing sm s@(Status sci _) hs cookiejar
178+ | check = Nothing
179+ | otherwise = Just $ E.toException $ StatusCodeException s hs cookiejar
180+ where
181+#endif
182+ check = case sm of
183+ Nothing -> 200 <= sci && sci < 300
184+ Just sm' -> sci `elem` map fst sm'
185+
186+onHttpException :: MonadError Error m => HttpException -> m a
187+onHttpException = throwError . HTTPError
src/GitHub/App/Request.hsnew file+38
@@ -0,0 +1,38 @@
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+ -}
5+
6+{-# LANGUAGE CPP #-}
7+
8+module GitHub.App.Request
9+ ( executeAppRequest
10+ , executeAppRequestWithMgr
11+ ) where
12+
13+import GitHub.Data (Error (..))
14+import GitHub.Data.Request (Request)
15+import GitHub.Request (executeRequestWithMgr)
16+import Network.HTTP.Client (Manager)
17+import Network.HTTP.Client.TLS (newTlsManager)
18+
19+import GitHub.App.Auth (InstallationAuth, obtainAccessToken)
20+
21+
22+executeAppRequest :: InstallationAuth -> Request k a -> IO (Either Error a)
23+executeAppRequest instAuth req = do
24+ manager <- newTlsManager
25+ x <- executeAppRequestWithMgr manager instAuth req
26+#if !MIN_VERSION_http_client(0, 4, 18)
27+ closeManager manager
28+#endif
29+ pure x
30+
31+executeAppRequestWithMgr
32+ :: Manager
33+ -> InstallationAuth
34+ -> Request k a
35+ -> IO (Either Error a)
36+executeAppRequestWithMgr mgr instAuth req = obtainAccessToken mgr instAuth >>= \case
37+ Right auth -> executeRequestWithMgr mgr auth req
38+ Left err -> pure $ Left err
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+ -}
5+
6+{-# LANGUAGE CPP #-}
7+
8+module GitHub.Data.Apps where
9+
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+ -}
5+
6+{-# LANGUAGE CPP #-}
7+
8+module GitHub.Data.Installations where
9+
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