@@ -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/.
7+{-# LANGUAGE DataKinds #-}
18+import Prelude hiding (exp)
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 ((<>))
31+import Data.Text (Text)
32+import qualified Data.Text as T
33+import Data.Text.Encoding (encodeUtf8)
34+import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
35+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
36+import GitHub.Auth (Auth (OAuth))
37+import GitHub.Data.Apps (App)
38+import GitHub.Data.Definitions (Error (HTTPError))
39+import GitHub.Data.Id (Id, untagId)
40+import GitHub.Data.Installations (Installation)
41+import GitHub.Request (StatusMap, parseResponseJSON)
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,
49+-- | JWT expiration time. Maximum accepted by GitHub is 10 minutes
50+jwtExpTime :: NominalDiffTime
53+-- | Installation access token expiration time. It is fixed by GitHub and is equal to 1 hour
54+instKeyExpTime :: NominalDiffTime
57+-- | When to renew the installation access token
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
65+baseUrl = "https://api.github.com"
68+-- | Credentials of a GitHub App
69+data AppAuth = AppAuth
70+ { aaAppId :: !(Id App)
71+ , aaPrivateKey :: !PrivateKey
74+-- | Cached GitHub installation access token
75+data InstallationToken = InstallationToken
77+ , itExpirationTime :: !UTCTime
80+instance FromJSON InstallationToken where
81+ parseJSON = withObject "Installation access token" $ \o ->
83+ <$> (OAuth . encodeUtf8 <$> o .: "token")
84+ <*> o .: "expires_at"
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
96+-- | Smart constructor for 'InstallationAuth'
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
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
116+ jwt = encodeSigned (RSAPrivateKey iaAppPrivateKey) mempty claims
118+ req <- HTTP.parseRequest . T.unpack $ url
120+ { HTTP.requestHeaders =
121+ [ ("Authorization", "Bearer " <> encodeUtf8 jwt)
122+ , ("Accept", "application/vnd.github.machine-man-preview+json")
123+ , ("User-Agent", "github-app/Haskell")
125+ , HTTP.checkResponse = successOrMissing Nothing
126+ , HTTP.method = "POST"
129+ toJsonTime = fromMaybe (error "impossible") . numericDate
130+ url = baseUrl <> "/installations/" <> iaInstallationId <> "/access_tokens"
132+-- | Get a valid access token
134+-- Tries to use the cached one. If it is invalid, requests a new one
135+-- and caches it for future use.
139+ -> IO (Either Error Auth)
140+obtainAccessToken mgr ia@InstallationAuth{..} = readMVar iaToken >>= \case
142+ Just InstallationToken{itToken, itExpirationTime} -> do
143+ currentTime <- getCurrentTime
144+ if itExpirationTime `diffUTCTime` currentTime < bufferTime
146+ else pure $ Right itToken
148+ renew :: IO (Either Error Auth)
149+ renew = bracketOnError (takeMVar iaToken) (putMVar iaToken) $ \_ -> do
150+ req <- createAccessTokenR ia
151+ result <- runExceptT $ httpLbs' req >>= parseResponseJSON
153+ Right newToken -> putMVar iaToken (Just newToken) $> Right (itToken newToken)
154+ Left err -> putMVar iaToken Nothing $> Left err
156+ httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString)
157+ httpLbs' req' = lift (httpLbs req' mgr) `catch` onHttpException
161+---------------------------------------
162+-- Copy-pasted from the github package
163+---------------------------------------
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
170+ chunk <- HTTP.brReadSome (HTTP.responseBody res) 1024
171+ let res' = fmap (const ()) res
172+ HTTP.throwHttp $ HTTP.StatusCodeException res' (LBS.toStrict chunk)
174+ HTTP.Status sci _ = HTTP.responseStatus res
176+successOrMissing :: Maybe (StatusMap a) -> Status -> ResponseHeaders -> HTTP.CookieJar -> Maybe E.SomeException
177+successOrMissing sm s@(Status sci _) hs cookiejar
179+ | otherwise = Just $ E.toException $ StatusCodeException s hs cookiejar
183+ Nothing -> 200 <= sci && sci < 300
184+ Just sm' -> sci `elem` map fst sm'
186+onHttpException :: MonadError Error m => HttpException -> m a
187+onHttpException = throwError . HTTPError