@@ -7,48 +7,47 @@
77{-# LANGUAGE DataKinds #-}
88
99module GitHub.App.Auth
10− ( AppAuth (..)
11−
12− , InstallationAuth
10+ ( InstallationAuth
1311 , mkInstallationAuth
1412
1513 , obtainAccessToken
14+
15+ , AppId
16+ , InstallationId
1617 ) where
1718
1819import Prelude hiding (exp)
1920
2021import Control.Concurrent (MVar, newMVar, putMVar, readMVar, takeMVar)
2122import 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
23+import Control.Monad.Except (MonadError (throwError), ExceptT, runExceptT)
2724import Data.Functor (($>))
25+import Crypto.Types.PubKey.RSA (PrivateKey)
26+import Data.Aeson (FromJSON (..), withObject, (.:))
2827import Data.Maybe (fromMaybe)
2928import Data.Semigroup ((<>))
30−import Data.Tagged
3129import Data.Text (Text)
3230import qualified Data.Text as T
3331import Data.Text.Encoding (encodeUtf8)
3432import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
3533import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
34+import Control.Monad.Trans (lift)
35+import Data.Word (Word64)
3636import GitHub.Auth (Auth (OAuth))
37−import GitHub.Data.Apps (App)
3837import GitHub.Data.Definitions (Error (HTTPError))
39−import GitHub.Data.Id (Id, untagId)
40−import GitHub.Data.Installations (Installation)
41−import GitHub.Request (StatusMap, parseResponseJSON)
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)
4242import Network.HTTP.Client as HTTP
4343import qualified Network.HTTP.Client.Internal as HTTP
4444import qualified Network.HTTP.Types as HTTP
45−import Web.JWT (JWTClaimsSet (exp, iat, iss), Signer (RSAPrivateKey), encodeSigned, numericDate,
46− stringOrURI)
45+import qualified Data.ByteString.Lazy as LBS
4746
4847
4948-- | JWT expiration time. Maximum accepted by GitHub is 10 minutes
5049jwtExpTime :: NominalDiffTime
51−jwtExpTime = 300
50+jwtExpTime = 600
5251
5352-- | Installation access token expiration time. It is fixed by GitHub and is equal to 1 hour
5453instKeyExpTime :: NominalDiffTime
@@ -65,16 +64,10 @@ baseUrl :: Text
6564baseUrl = "https://api.github.com"
6665
6766
68−-- | Credentials of a GitHub App
69−data AppAuth = AppAuth
70− { aaAppId :: !(Id App)
71− , aaPrivateKey :: !PrivateKey
72− }
73−
7467-- | Cached GitHub installation access token
7568data InstallationToken = InstallationToken
76− { itToken :: !Auth
77− , itExpirationTime :: !UTCTime
69+ { itToken :: Auth
70+ , itExpirationTime :: UTCTime
7871 } deriving (Show)
7972
8073instance FromJSON InstallationToken where
@@ -84,7 +77,7 @@ instance FromJSON InstallationToken where
8477 <*> o .: "expires_at"
8578
8679
87−-- | Credentials required for an App to authenticate as an installation
80+-- | Credentials required for an app to authenticate as an installation
8881data InstallationAuth = InstallationAuth
8982 { iaClaimsSet :: !JWTClaimsSet -- ^ Prefilled claims set
9083 , iaAppPrivateKey :: !PrivateKey -- ^ Private key to sign token requests
@@ -93,16 +86,20 @@ data InstallationAuth = InstallationAuth
9386 }
9487
9588
89+type AppId = Word64
90+type InstallationId = Word64
91+
9692-- | Smart constructor for 'InstallationAuth'
9793mkInstallationAuth
98− :: AppAuth
99− -> Id Installation
94+ :: AppId -- ^ GitHub App ID
95+ -> PrivateKey -- ^ GitHub App Private Key
96+ -> InstallationId -- ^ Installation ID
10097 -> IO InstallationAuth
101−mkInstallationAuth AppAuth{aaAppId, aaPrivateKey} instId = do
98+mkInstallationAuth appId pk instId = do
10299 varToken <- newMVar Nothing
103− let issuer = fromMaybe (error "impossible") . stringOrURI . T.pack . show . untagId $ aaAppId
100+ let issuer = fromMaybe (error "impossible") . stringOrURI . T.pack . show $ appId
104101 claimsSet = mempty { iss = Just issuer }
105− pure $ InstallationAuth claimsSet aaPrivateKey (T.pack . show . untagId $ instId) varToken
102+ pure $ InstallationAuth claimsSet pk (T.pack . show $ instId) varToken
106103
107104-- | Create a request which, when executed, will obtain a new access token
108105createAccessTokenR :: InstallationAuth -> IO HTTP.Request
@@ -113,15 +110,11 @@ createAccessTokenR InstallationAuth{..} = do
113110 { iat = Just $ toJsonTime currentTime
114111 , exp = Just $ toJsonTime expiryTime
115112 }
116− jwt = encodeSigned (RSAPrivateKey iaAppPrivateKey) mempty claims
113+ jwt = encodeSigned (RSAPrivateKey iaAppPrivateKey) claims
117114
118115 req <- HTTP.parseRequest . T.unpack $ url
119116 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− ]
117+ { HTTP.requestHeaders = [("Authorization", "Bearer " <> encodeUtf8 jwt)]
125118 , HTTP.checkResponse = successOrMissing Nothing
126119 , HTTP.method = "POST"
127120 }
@@ -148,7 +141,7 @@ obtainAccessToken mgr ia@InstallationAuth{..} = readMVar iaToken >>= \case
148141 renew :: IO (Either Error Auth)
149142 renew = bracketOnError (takeMVar iaToken) (putMVar iaToken) $ \_ -> do
150143 req <- createAccessTokenR ia
151− result <- runExceptT $ httpLbs' req >>= parseResponseJSON
144+ result <- runExceptT $ httpLbs' req >>= parseResponse
152145 case result of
153146 Right newToken -> putMVar iaToken (Just newToken) $> Right (itToken newToken)
154147 Left err -> putMVar iaToken Nothing $> Left err