@@ -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.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