@@ -7,47 +7,48 @@
77{-# LANGUAGE DataKinds #-}
88
99module GitHub.App.Auth
10− ( InstallationAuth
10+ ( AppAuth (..)
11+
12+ , InstallationAuth
1113 , mkInstallationAuth
1214
1315 , obtainAccessToken
14−
15− , AppId
16− , InstallationId
1716 ) where
1817
1918import Prelude hiding (exp)
2019
2120import Control.Concurrent (MVar, newMVar, putMVar, readMVar, takeMVar)
2221import 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)
22+import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT)
23+import Control.Monad.Trans (lift)
24+import Crypto.PubKey.RSA (PrivateKey)
2625import Data.Aeson (FromJSON (..), withObject, (.:))
26+import qualified Data.ByteString.Lazy as LBS
27+import Data.Functor (($>))
2728import Data.Maybe (fromMaybe)
2829import Data.Semigroup ((<>))
30+import Data.Tagged
2931import Data.Text (Text)
3032import qualified Data.Text as T
3133import Data.Text.Encoding (encodeUtf8)
3234import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
3335import 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)
3738import 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)
39+import GitHub.Data.Id (Id, untagId)
40+import GitHub.Data.Installations (Installation)
41+import GitHub.Request (StatusMap, parseResponseJSON)
4242import Network.HTTP.Client as HTTP
4343import qualified Network.HTTP.Client.Internal as HTTP
4444import 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,
46+ stringOrURI)
4647
4748
4849-- | JWT expiration time. Maximum accepted by GitHub is 10 minutes
4950jwtExpTime :: NominalDiffTime
50−jwtExpTime = 600
51+jwtExpTime = 300
5152
5253-- | Installation access token expiration time. It is fixed by GitHub and is equal to 1 hour
5354instKeyExpTime :: NominalDiffTime
@@ -64,10 +65,16 @@ baseUrl :: Text
6465baseUrl = "https://api.github.com"
6566
6667
68+-- | Credentials of a GitHub App
69+data AppAuth = AppAuth
70+ { aaAppId :: !(Id App)
71+ , aaPrivateKey :: !PrivateKey
72+ }
73+
6774-- | Cached GitHub installation access token
6875data InstallationToken = InstallationToken
69− { itToken :: Auth
70− , itExpirationTime :: UTCTime
76+ { itToken :: !Auth
77+ , itExpirationTime :: !UTCTime
7178 } deriving (Show)
7279
7380instance FromJSON InstallationToken where
@@ -77,7 +84,7 @@ instance FromJSON InstallationToken where
7784 <*> o .: "expires_at"
7885
7986
80−-- | Credentials required for an app to authenticate as an installation
87+-- | Credentials required for an App to authenticate as an installation
8188data InstallationAuth = InstallationAuth
8289 { iaClaimsSet :: !JWTClaimsSet -- ^ Prefilled claims set
8390 , iaAppPrivateKey :: !PrivateKey -- ^ Private key to sign token requests
@@ -86,20 +93,16 @@ data InstallationAuth = InstallationAuth
8693 }
8794
8895
89−type AppId = Word64
90−type InstallationId = Word64
91−
9296-- | Smart constructor for 'InstallationAuth'
9397mkInstallationAuth
94− :: AppId -- ^ GitHub App ID
95− -> PrivateKey -- ^ GitHub App Private Key
96− -> InstallationId -- ^ Installation ID
98+ :: AppAuth
99+ -> Id Installation
97100 -> IO InstallationAuth
98−mkInstallationAuth appId pk instId = do
101+mkInstallationAuth AppAuth{aaAppId, aaPrivateKey} instId = do
99102 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
101104 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
103106
104107-- | Create a request which, when executed, will obtain a new access token
105108createAccessTokenR :: InstallationAuth -> IO HTTP.Request
@@ -110,11 +113,15 @@ createAccessTokenR InstallationAuth{..} = do
110113 { iat = Just $ toJsonTime currentTime
111114 , exp = Just $ toJsonTime expiryTime
112115 }
113− jwt = encodeSigned (RSAPrivateKey iaAppPrivateKey) claims
116+ jwt = encodeSigned (RSAPrivateKey iaAppPrivateKey) mempty claims
114117
115118 req <- HTTP.parseRequest . T.unpack $ url
116119 pure req
117− { HTTP.requestHeaders = [("Authorization", "Bearer " <> encodeUtf8 jwt)]
120+ { HTTP.requestHeaders =
121+ [ ("Authorization", "Bearer " <> encodeUtf8 jwt)
122+ , ("Accept", "application/vnd.github.machine-man-preview+json")
123+ , ("User-Agent", "github-app/Haskell")
124+ ]
118125 , HTTP.checkResponse = successOrMissing Nothing
119126 , HTTP.method = "POST"
120127 }
@@ -141,7 +148,7 @@ obtainAccessToken mgr ia@InstallationAuth{..} = readMVar iaToken >>= \case
141148 renew :: IO (Either Error Auth)
142149 renew = bracketOnError (takeMVar iaToken) (putMVar iaToken) $ \_ -> do
143150 req <- createAccessTokenR ia
144− result <- runExceptT $ httpLbs' req >>= parseResponse
151+ result <- runExceptT $ httpLbs' req >>= parseResponseJSON
145152 case result of
146153 Right newToken -> putMVar iaToken (Just newToken) $> Right (itToken newToken)
147154 Left err -> putMVar iaToken Nothing $> Left err