@@ -1,187 +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−{-# 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.Tagged
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,
46− stringOrURI)
47−
48−
49−-- | JWT expiration time. Maximum accepted by GitHub is 10 minutes
50−jwtExpTime :: NominalDiffTime
51−jwtExpTime = 300
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) mempty 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 >>= parseResponseJSON
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