@@ -0,0 +1,180 @@
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+ ( InstallationAuth
11+ , mkInstallationAuth
12+
13+ , obtainAccessToken
14+
15+ , AppId
16+ , InstallationId
17+ ) where
18+
19+import Prelude hiding (exp)
20+
21+import Control.Concurrent (MVar, newMVar, putMVar, readMVar, takeMVar)
22+import Control.Exception.Safe (bracketOnError, catch)
23+import Control.Monad.Except (MonadError (throwError), ExceptT, runExceptT)
24+import Data.Functor (($>))
25+import Crypto.Types.PubKey.RSA (PrivateKey)
26+import Data.Aeson (FromJSON (..), withObject, (.:))
27+import Data.Maybe (fromMaybe)
28+import Data.Semigroup ((<>))
29+import Data.Text (Text)
30+import qualified Data.Text as T
31+import Data.Text.Encoding (encodeUtf8)
32+import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
33+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
34+import Control.Monad.Trans (lift)
35+import Data.Word (Word64)
36+import GitHub.Auth (Auth (OAuth))
37+import GitHub.Data.Definitions (Error (HTTPError))
38+import GitHub.Data.Request (StatusMap)
39+import GitHub.Request (parseResponse)
40+import Web.JWT (JWTClaimsSet (exp, iat, iss), Signer (RSAPrivateKey), encodeSigned,
41+ numericDate, stringOrURI)
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 qualified Data.ByteString.Lazy as LBS
46+
47+
48+-- | JWT expiration time. Maximum accepted by GitHub is 10 minutes
49+jwtExpTime :: NominalDiffTime
50+jwtExpTime = 600
51+
52+-- | Installation access token expiration time. It is fixed by GitHub and is equal to 1 hour
53+instKeyExpTime :: NominalDiffTime
54+instKeyExpTime = 3600
55+
56+-- | When to renew the installation access token
57+--
58+-- We renew the access token when it is valid for less than 'bufferTime'
59+-- just to be on the safe side.
60+bufferTime :: NominalDiffTime
61+bufferTime = instKeyExpTime * 0.25
62+
63+baseUrl :: Text
64+baseUrl = "https://api.github.com"
65+
66+
67+-- | Cached GitHub installation access token
68+data InstallationToken = InstallationToken
69+ { itToken :: Auth
70+ , itExpirationTime :: UTCTime
71+ } deriving (Show)
72+
73+instance FromJSON InstallationToken where
74+ parseJSON = withObject "Installation access token" $ \o ->
75+ InstallationToken
76+ <$> (OAuth . encodeUtf8 <$> o .: "token")
77+ <*> o .: "expires_at"
78+
79+
80+-- | Credentials required for an app to authenticate as an installation
81+data InstallationAuth = InstallationAuth
82+ { iaClaimsSet :: !JWTClaimsSet -- ^ Prefilled claims set
83+ , iaAppPrivateKey :: !PrivateKey -- ^ Private key to sign token requests
84+ , iaInstallationId :: !Text -- ^ Installation id
85+ , iaToken :: !(MVar (Maybe InstallationToken)) -- ^ Installation Auth token
86+ }
87+
88+
89+type AppId = Word64
90+type InstallationId = Word64
91+
92+-- | Smart constructor for 'InstallationAuth'
93+mkInstallationAuth
94+ :: AppId -- ^ GitHub App ID
95+ -> PrivateKey -- ^ GitHub App Private Key
96+ -> InstallationId -- ^ Installation ID
97+ -> IO InstallationAuth
98+mkInstallationAuth appId pk instId = do
99+ varToken <- newMVar Nothing
100+ let issuer = fromMaybe (error "impossible") . stringOrURI . T.pack . show $ appId
101+ claimsSet = mempty { iss = Just issuer }
102+ pure $ InstallationAuth claimsSet pk (T.pack . show $ instId) varToken
103+
104+-- | Create a request which, when executed, will obtain a new access token
105+createAccessTokenR :: InstallationAuth -> IO HTTP.Request
106+createAccessTokenR InstallationAuth{..} = do
107+ currentTime <- utcTimeToPOSIXSeconds <$> getCurrentTime
108+ let expiryTime = currentTime + jwtExpTime
109+ claims = iaClaimsSet
110+ { iat = Just $ toJsonTime currentTime
111+ , exp = Just $ toJsonTime expiryTime
112+ }
113+ jwt = encodeSigned (RSAPrivateKey iaAppPrivateKey) claims
114+
115+ req <- HTTP.parseRequest . T.unpack $ url
116+ pure req
117+ { HTTP.requestHeaders = [("Authorization", "Bearer " <> encodeUtf8 jwt)]
118+ , HTTP.checkResponse = successOrMissing Nothing
119+ , HTTP.method = "POST"
120+ }
121+ where
122+ toJsonTime = fromMaybe (error "impossible") . numericDate
123+ url = baseUrl <> "/installations/" <> iaInstallationId <> "/access_tokens"
124+
125+-- | Get a valid access token
126+--
127+-- Tries to use the cached one. If it is invalid, requests a new one
128+-- and caches it for future use.
129+obtainAccessToken
130+ :: Manager
131+ -> InstallationAuth
132+ -> IO (Either Error Auth)
133+obtainAccessToken mgr ia@InstallationAuth{..} = readMVar iaToken >>= \case
134+ Nothing -> renew
135+ Just InstallationToken{itToken, itExpirationTime} -> do
136+ currentTime <- getCurrentTime
137+ if itExpirationTime `diffUTCTime` currentTime < bufferTime
138+ then renew
139+ else pure $ Right itToken
140+ where
141+ renew :: IO (Either Error Auth)
142+ renew = bracketOnError (takeMVar iaToken) (putMVar iaToken) $ \_ -> do
143+ req <- createAccessTokenR ia
144+ result <- runExceptT $ httpLbs' req >>= parseResponse
145+ case result of
146+ Right newToken -> putMVar iaToken (Just newToken) $> Right (itToken newToken)
147+ Left err -> putMVar iaToken Nothing $> Left err
148+
149+ httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString)
150+ httpLbs' req' = lift (httpLbs req' mgr) `catch` onHttpException
151+
152+
153+
154+---------------------------------------
155+-- Copy-pasted from the github package
156+---------------------------------------
157+
158+#if MIN_VERSION_http_client(0,5,0)
159+successOrMissing :: Maybe (StatusMap a) -> HTTP.Request -> HTTP.Response HTTP.BodyReader -> IO ()
160+successOrMissing sm _req res
161+ | check = pure ()
162+ | otherwise = do
163+ chunk <- HTTP.brReadSome (HTTP.responseBody res) 1024
164+ let res' = fmap (const ()) res
165+ HTTP.throwHttp $ HTTP.StatusCodeException res' (LBS.toStrict chunk)
166+ where
167+ HTTP.Status sci _ = HTTP.responseStatus res
168+#else
169+successOrMissing :: Maybe (StatusMap a) -> Status -> ResponseHeaders -> HTTP.CookieJar -> Maybe E.SomeException
170+successOrMissing sm s@(Status sci _) hs cookiejar
171+ | check = Nothing
172+ | otherwise = Just $ E.toException $ StatusCodeException s hs cookiejar
173+ where
174+#endif
175+ check = case sm of
176+ Nothing -> 200 <= sci && sci < 300
177+ Just sm' -> sci `elem` map fst sm'
178+
179+onHttpException :: MonadError Error m => HttpException -> m a
180+onHttpException = throwError . HTTPError