@@ -7,23 +7,24 @@
7{-# LANGUAGE DataKinds #-}
7{-# LANGUAGE DataKinds #-}
9module GitHub.App.Auth
9module GitHub.App.Auth
10− ( InstallationAuth
12+ , InstallationAuth
11 , mkInstallationAuth
13 , mkInstallationAuth
13 , obtainAccessToken
15 , obtainAccessToken
19import Prelude hiding (exp)
18import Prelude hiding (exp)
21import Control.Concurrent (MVar, newMVar, putMVar, readMVar, takeMVar)
20import Control.Concurrent (MVar, newMVar, putMVar, readMVar, takeMVar)
22import Control.Exception.Safe (bracketOnError, catch)
21import Control.Exception.Safe (bracketOnError, catch)
23−import Control.Monad.Except (MonadError (throwError), ExceptT, runExceptT)
22+import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT)
24−import Data.Functor (($>))
23+import Control.Monad.Trans (lift)
25import Crypto.Types.PubKey.RSA (PrivateKey)
24import Crypto.Types.PubKey.RSA (PrivateKey)
26import Data.Aeson (FromJSON (..), withObject, (.:))
25import Data.Aeson (FromJSON (..), withObject, (.:))
26+import qualified Data.ByteString.Lazy as LBS
27+import Data.Functor (($>))
27import Data.Maybe (fromMaybe)
28import Data.Maybe (fromMaybe)
28import Data.Semigroup ((<>))
29import Data.Semigroup ((<>))
29import Data.Text (Text)
30import Data.Text (Text)
@@ -31,18 +32,18 @@ import qualified Data.Text as T
31import Data.Text.Encoding (encodeUtf8)
32import Data.Text.Encoding (encodeUtf8)
32import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
33import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
33import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
34import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
34−import Control.Monad.Trans (lift)
35−import Data.Word (Word64)
36import GitHub.Auth (Auth (OAuth))
35import GitHub.Auth (Auth (OAuth))
36+import GitHub.Data.Apps (App)
37import GitHub.Data.Definitions (Error (HTTPError))
37import GitHub.Data.Definitions (Error (HTTPError))
38+import GitHub.Data.Id (Id, untagId)
39+import GitHub.Data.Installations (Installation)
38import GitHub.Data.Request (StatusMap)
40import GitHub.Data.Request (StatusMap)
39import GitHub.Request (parseResponse)
41import GitHub.Request (parseResponse)
40−import Web.JWT (JWTClaimsSet (exp, iat, iss), Signer (RSAPrivateKey), encodeSigned,
41− numericDate, stringOrURI)
42import Network.HTTP.Client as HTTP
42import Network.HTTP.Client as HTTP
43import qualified Network.HTTP.Client.Internal as HTTP
43import qualified Network.HTTP.Client.Internal as HTTP
44import qualified Network.HTTP.Types as HTTP
44import qualified Network.HTTP.Types as HTTP
45−import qualified Data.ByteString.Lazy as LBS
45+import Web.JWT (JWTClaimsSet (exp, iat, iss), Signer (RSAPrivateKey), encodeSigned, numericDate,
48-- | JWT expiration time. Maximum accepted by GitHub is 10 minutes
49-- | JWT expiration time. Maximum accepted by GitHub is 10 minutes
@@ -64,10 +65,16 @@ baseUrl :: Text
64baseUrl = "https://api.github.com"
65baseUrl = "https://api.github.com"
68+-- | Credentials of a GitHub App
69+data AppAuth = AppAuth
70+ { aaAppId :: !(Id App)
71+ , aaPrivateKey :: !PrivateKey
67-- | Cached GitHub installation access token
74-- | Cached GitHub installation access token
68data InstallationToken = InstallationToken
75data InstallationToken = InstallationToken
69− { itToken :: Auth
76+ { itToken :: !Auth
70− , itExpirationTime :: UTCTime
77+ , itExpirationTime :: !UTCTime
71 } deriving (Show)
78 } deriving (Show)
73instance FromJSON InstallationToken where
80instance FromJSON InstallationToken where
@@ -77,7 +84,7 @@ instance FromJSON InstallationToken where
77 <*> o .: "expires_at"
84 <*> o .: "expires_at"
80−-- | Credentials required for an app to authenticate as an installation
87+-- | Credentials required for an App to authenticate as an installation
81data InstallationAuth = InstallationAuth
88data InstallationAuth = InstallationAuth
82 { iaClaimsSet :: !JWTClaimsSet -- ^ Prefilled claims set
89 { iaClaimsSet :: !JWTClaimsSet -- ^ Prefilled claims set
83 , iaAppPrivateKey :: !PrivateKey -- ^ Private key to sign token requests
90 , iaAppPrivateKey :: !PrivateKey -- ^ Private key to sign token requests
@@ -86,20 +93,16 @@ data InstallationAuth = InstallationAuth
90−type InstallationId = Word64
92-- | Smart constructor for 'InstallationAuth'
96-- | Smart constructor for 'InstallationAuth'
93mkInstallationAuth
97mkInstallationAuth
94− :: AppId -- ^ GitHub App ID
98+ :: AppAuth
95− -> PrivateKey -- ^ GitHub App Private Key
96− -> InstallationId -- ^ Installation ID
99+ -> Id Installation
97 -> IO InstallationAuth
100 -> IO InstallationAuth
98−mkInstallationAuth appId pk instId = do
101+mkInstallationAuth AppAuth{aaAppId, aaPrivateKey} instId = do
99 varToken <- newMVar Nothing
102 varToken <- newMVar Nothing
100− let issuer = fromMaybe (error "impossible") . stringOrURI . T.pack . show $ appId
103+ let issuer = fromMaybe (error "impossible") . stringOrURI . T.pack . show . untagId $ aaAppId
101 claimsSet = mempty { iss = Just issuer }
104 claimsSet = mempty { iss = Just issuer }
102− pure $ InstallationAuth claimsSet pk (T.pack . show $ instId) varToken
105+ pure $ InstallationAuth claimsSet aaPrivateKey (T.pack . show . untagId $ instId) varToken
104-- | Create a request which, when executed, will obtain a new access token
107-- | Create a request which, when executed, will obtain a new access token
105createAccessTokenR :: InstallationAuth -> IO HTTP.Request
108createAccessTokenR :: InstallationAuth -> IO HTTP.Request