Skip to content

Commit ccc6c8f

Browse files
zylazyla
authored
Cache Github status token (#6)
* Github API success test * More tests * Cache access token within one process * Reuse cached token in subprocesses * Only fetch token at top level if the feature is actually enabled * Github told me to update actions/cache actions/cache#1510
1 parent 068be29 commit ccc6c8f

20 files changed

+411
-91
lines changed

‎.github/workflows/build.yml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -22,7 +22,7 @@ jobs:
2222
enable-stack: true
2323
stack-version: 'latest'
2424
- name: Cache
25-
uses: actions/cache@v1
25+
uses: actions/cache@v4
2626
env:
2727
cache-name: cache-stack
2828
with:

‎.github/workflows/release.yml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,7 @@ jobs:
2828
enable-stack: true
2929
stack-version: 'latest'
3030
- name: Cache
31-
uses: actions/cache@v1
31+
uses: actions/cache@v4
3232
env:
3333
cache-name: cache-stack
3434
with:

‎package.yaml‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -132,3 +132,6 @@ tests:
132132
- taskrunner
133133
- tasty
134134
- tasty-golden
135+
- wai
136+
- warp
137+
- http-types

‎src/App.hs‎

Lines changed: 29 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE TemplateHaskell #-}
22
{-# LANGUAGE DuplicateRecordFields #-}
3+
{-# LANGUAGE RecursiveDo #-}
34
{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
45

56
module App where
@@ -39,6 +40,7 @@ import Utils
3940
import qualified RemoteCache
4041
import RemoteCache (getLatestBuildHash)
4142
import CommitStatus (updateCommitStatus, StatusRequest (..))
43+
import qualified CommitStatus
4244
import qualified System.Process as Process
4345
import Control.Monad.EarlyReturn (withEarlyReturn, earlyReturn)
4446
import Data.Time.Format.ISO8601 (iso8601Show)
@@ -124,27 +126,35 @@ main = do
124126
responsePipeReadFd <- handleToFd responsePipeRead
125127
hSetBuffering responsePipeWrite LineBuffering
126128

127-
parentEnv <- getEnvironment
128-
129-
cwd <- getCurrentDirectory
130-
131-
-- TODO: handle spawn error here
132-
-- TODO: should we use withCreateProcess?
133-
-- TODO: should we use delegate_ctlc or DIY? See https://hackage.haskell.org/package/process-1.6.20.0/docs/System-Process.html#g:4
134-
-- -> We should DIY because we need to flush stream etc.
135-
(Nothing, Just stdoutPipe, Just stderrPipe, processHandle) <- Process.createProcess
136-
(proc args.cmd args.args) { std_in = UseHandle devnull, std_out = CreatePipe
137-
, std_err = CreatePipe
138-
, env=Just $ nubOrdOn fst $
139-
[ ("BASH_FUNC_snapshot%%", "() {\n" <> $(embedStringFile "src/snapshot.sh") <> "\n}")
140-
, ("_taskrunner_request_pipe", show requestPipeWriteFd)
141-
, ("_taskrunner_response_pipe", show responsePipeReadFd)
142-
] <> parentEnv
143-
}
129+
-- Recursive: AppState is used before process is started (mostly for logging)
130+
rec
131+
132+
appState <- AppState settings jobName buildId isToplevel <$> newIORef Nothing <*> newIORef Nothing <*> newIORef False <*> pure toplevelStderr <*> pure subprocessStderr <*> pure logFile
133+
<*> newIORef Nothing
134+
135+
when (isToplevel && appState.settings.enableCommitStatus) do
136+
-- Note: sets env for subprocesses, so has to be called before starting subprocess
137+
void $ CommitStatus.getClient appState
144138

145-
(subprocessStderrRead, subprocessStderr) <- createPipe
139+
parentEnv <- getEnvironment
140+
141+
cwd <- getCurrentDirectory
142+
143+
-- TODO: handle spawn error here
144+
-- TODO: should we use withCreateProcess?
145+
-- TODO: should we use delegate_ctlc or DIY? See https://hackage.haskell.org/package/process-1.6.20.0/docs/System-Process.html#g:4
146+
-- -> We should DIY because we need to flush stream etc.
147+
(Nothing, Just stdoutPipe, Just stderrPipe, processHandle) <- Process.createProcess
148+
(proc args.cmd args.args) { std_in = UseHandle devnull, std_out = CreatePipe
149+
, std_err = CreatePipe
150+
, env=Just $ nubOrdOn fst $
151+
[ ("BASH_FUNC_snapshot%%", "() {\n" <> $(embedStringFile "src/snapshot.sh") <> "\n}")
152+
, ("_taskrunner_request_pipe", show requestPipeWriteFd)
153+
, ("_taskrunner_response_pipe", show responsePipeReadFd)
154+
] <> parentEnv
155+
}
146156

147-
appState <- AppState settings jobName buildId isToplevel <$> newIORef Nothing <*> newIORef Nothing <*> newIORef False <*> pure toplevelStderr <*> pure subprocessStderr <*> pure logFile
157+
(subprocessStderrRead, subprocessStderr) <- createPipe
148158

149159
logDebug appState $ "Running command: " <> show (args.cmd : args.args)
150160
logDebug appState $ " buildId: " <> show buildId

‎src/CommitStatus.hs‎

Lines changed: 88 additions & 53 deletions
Original file line numberDiff line numberDiff line change
@@ -11,12 +11,12 @@ import qualified Data.Text as T
1111
import qualified Data.Text.Encoding as TE
1212
import qualified Network.HTTP.Client as HTTP
1313
import Network.HTTP.Client.TLS (tlsManagerSettings)
14-
import System.Environment (getEnv)
14+
import System.Environment (getEnv, lookupEnv, setEnv)
1515
import Network.HTTP.Types.Status (Status(..))
1616
import Data.Aeson.Decoding (eitherDecode)
1717
import qualified Data.Text as Text
1818
import Utils (getCurrentCommit, logError, logDebug)
19-
import Types (AppState)
19+
import Types (AppState(..), GithubClient(..))
2020

2121
-- Define the data types for the status update
2222
data StatusRequest = StatusRequest
@@ -33,70 +33,105 @@ newtype InstallationTokenResponse = InstallationTokenResponse
3333
} deriving (Show, Generic)
3434
deriving anyclass (FromJSON)
3535

36-
updateCommitStatus :: MonadIO m => AppState -> StatusRequest -> m ()
37-
updateCommitStatus appState statusRequest = liftIO do
36+
getClient :: AppState -> IO GithubClient
37+
getClient appState = do
38+
mClient <- readIORef appState.githubClient
39+
case mClient of
40+
Just client -> pure client
41+
Nothing -> do
42+
client <- initClient appState
43+
writeIORef appState.githubClient $ Just client
44+
pure client
45+
46+
initClient :: AppState -> IO GithubClient
47+
initClient appState = do
3848
-- Load environment variables
49+
apiUrl <- fromMaybe "https://api.github.com" <$> lookupEnv "GITHUB_API_URL"
3950
appId <- getEnv "GITHUB_APP_ID"
4051
installationId <- getEnv "GITHUB_INSTALLATION_ID"
4152
privateKeyStr <- getEnv "GITHUB_APP_PRIVATE_KEY"
4253
owner <- getEnv "GITHUB_REPOSITORY_OWNER"
4354
repo <- getEnv "GITHUB_REPOSITORY"
44-
45-
sha <- getCurrentCommit appState
46-
47-
let privateKeyBytes = encodeUtf8 $ Text.replace "|" "\n" $ toText privateKeyStr
48-
let privateKey = fromMaybe (error "Invalid github key") $ readRsaSecret privateKeyBytes
49-
50-
-- Create the JWT token
51-
now <- getPOSIXTime
52-
let claims = mempty { iss = stringOrURI $ T.pack appId
53-
, iat = numericDate now
54-
, exp = numericDate (now + 5 * 60)
55-
}
56-
let jwt = encodeSigned (EncodeRSAPrivateKey privateKey) (mempty { alg = Just RS256 }) claims
57-
5855
-- Prepare the HTTP manager
5956
manager <- HTTP.newManager tlsManagerSettings
6057

61-
-- Get the installation access token
62-
let installUrl = "https://api.github.com/app/installations/" ++ installationId ++ "/access_tokens"
63-
initRequest <- HTTP.parseRequest installUrl
64-
let request = initRequest
65-
{ HTTP.method = "POST"
66-
, HTTP.requestHeaders =
67-
[ ("Authorization", "Bearer " <> TE.encodeUtf8 jwt)
68-
, ("Accept", "application/vnd.github.v3+json")
69-
, ("User-Agent", "restaumatic-bot")
70-
]
71-
}
72-
response <- HTTP.httpLbs request manager
73-
let mTokenResponse = eitherDecode @InstallationTokenResponse (HTTP.responseBody response)
74-
case mTokenResponse of
75-
Left err -> do
76-
logError appState $ "CommitStatus: Failed to parse installation token response: " <> show err
77-
logError appState $ "CommitStatus: Response: " <> decodeUtf8 response.responseBody
78-
exitFailure
79-
Right tokenResponse -> do
80-
let accessToken = tokenResponse.token
58+
let createToken = do
59+
let privateKeyBytes = encodeUtf8 $ Text.replace "|" "\n" $ toText privateKeyStr
60+
let privateKey = fromMaybe (error "Invalid github key") $ readRsaSecret privateKeyBytes
61+
62+
-- Create the JWT token
63+
now <- getPOSIXTime
64+
let claims = mempty { iss = stringOrURI $ T.pack appId
65+
, iat = numericDate now
66+
, exp = numericDate (now + 5 * 60)
67+
}
68+
let jwt = encodeSigned (EncodeRSAPrivateKey privateKey) (mempty { alg = Just RS256 }) claims
8169

82-
-- Prepare the status update request
83-
let statusUrl = "https://api.github.com/repos/" ++ owner ++ "/" ++ repo ++ "/statuses/" ++ toString sha
84-
initStatusRequest <- HTTP.parseRequest statusUrl
85-
let statusReq = initStatusRequest
70+
-- Get the installation access token
71+
let installUrl = apiUrl <> "/app/installations/" ++ installationId ++ "/access_tokens"
72+
initRequest <- HTTP.parseRequest installUrl
73+
let request = initRequest
8674
{ HTTP.method = "POST"
8775
, HTTP.requestHeaders =
88-
[ ("Authorization", "Bearer " <> TE.encodeUtf8 accessToken)
76+
[ ("Authorization", "Bearer " <> TE.encodeUtf8 jwt)
8977
, ("Accept", "application/vnd.github.v3+json")
90-
, ("Content-Type", "application/json")
9178
, ("User-Agent", "restaumatic-bot")
9279
]
93-
, HTTP.requestBody = HTTP.RequestBodyLBS $ encode statusRequest
9480
}
95-
statusResponse <- HTTP.httpLbs statusReq manager
96-
if statusResponse.responseStatus.statusCode == 201
97-
then
98-
logDebug appState "Commit status updated successfully"
99-
else do
100-
logError appState $ "CommitStatus: Failed to update commit status: " <> show statusResponse
101-
logError appState $ "CommitStatus: Response: " <> decodeUtf8 response.responseBody
102-
exitFailure
81+
response <- HTTP.httpLbs request manager
82+
let mTokenResponse = eitherDecode @InstallationTokenResponse (HTTP.responseBody response)
83+
case mTokenResponse of
84+
Left err -> do
85+
logError appState $ "CommitStatus: Failed to parse installation token response: " <> show err
86+
logError appState $ "CommitStatus: Response: " <> decodeUtf8 response.responseBody
87+
88+
-- FIXME: handle the error better
89+
exitFailure
90+
Right tokenResponse ->
91+
pure tokenResponse.token
92+
93+
-- Try to read token from environment variable
94+
-- Otherwise generate a new one, and set env for future uses (also in child processes)
95+
accessToken <- lookupEnv "_taskrunner_github_access_token" >>= \case
96+
Just token -> pure $ T.pack token
97+
Nothing -> do
98+
token <- createToken
99+
setEnv "_taskrunner_github_access_token" $ T.unpack token
100+
pure token
101+
102+
pure $ GithubClient { apiUrl = T.pack apiUrl
103+
, appId = T.pack appId
104+
, installationId = T.pack installationId
105+
, privateKey = T.pack privateKeyStr
106+
, owner = T.pack owner
107+
, repo = T.pack repo
108+
, manager = manager
109+
, accessToken = accessToken
110+
}
111+
112+
updateCommitStatus :: MonadIO m => AppState -> StatusRequest -> m ()
113+
updateCommitStatus appState statusRequest = liftIO do
114+
client <- getClient appState
115+
sha <- getCurrentCommit appState
116+
117+
-- Prepare the status update request
118+
let statusUrl = toString client.apiUrl <> "/repos/" ++ toString client.owner ++ "/" ++ toString client.repo ++ "/statuses/" ++ toString sha
119+
initStatusRequest <- HTTP.parseRequest statusUrl
120+
let statusReq = initStatusRequest
121+
{ HTTP.method = "POST"
122+
, HTTP.requestHeaders =
123+
[ ("Authorization", "Bearer " <> TE.encodeUtf8 client.accessToken)
124+
, ("Accept", "application/vnd.github.v3+json")
125+
, ("Content-Type", "application/json")
126+
, ("User-Agent", "restaumatic-bot")
127+
]
128+
, HTTP.requestBody = HTTP.RequestBodyLBS $ encode statusRequest
129+
}
130+
statusResponse <- HTTP.httpLbs statusReq client.manager
131+
if statusResponse.responseStatus.statusCode == 201
132+
then
133+
logDebug appState "Commit status updated successfully"
134+
else do
135+
logError appState $ "CommitStatus: Failed to update commit status: " <> show statusResponse
136+
logError appState $ "CommitStatus: Response: " <> decodeUtf8 statusResponse.responseBody
137+
exitFailure

‎src/Types.hs‎

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@ module Types where
33
import Universum
44
import SnapshotCliArgs (SnapshotCliArgs)
55
import Data.Aeson (FromJSON, ToJSON)
6+
import qualified Network.HTTP.Client as HTTP
67

78
data Settings = Settings
89
{ stateDirectory :: FilePath
@@ -48,4 +49,19 @@ data AppState = AppState
4849
, toplevelStderr :: Handle
4950
, subprocessStderr :: Handle
5051
, logOutput :: Handle
52+
53+
-- | Lazily initialized Github client
54+
, githubClient :: IORef (Maybe GithubClient)
55+
}
56+
57+
-- Unfortunately the type has to live there due to circular dependencies (AppState -> GithubClient -> AppState)
58+
data GithubClient = GithubClient
59+
{ apiUrl :: Text
60+
, appId :: Text
61+
, installationId :: Text
62+
, privateKey :: Text
63+
, owner :: Text
64+
, repo :: Text
65+
, manager :: HTTP.Manager
66+
, accessToken :: Text
5167
}

‎taskrunner.cabal‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -208,6 +208,7 @@ test-suite taskrunner-test
208208
type: exitcode-stdio-1.0
209209
main-is: Spec.hs
210210
other-modules:
211+
FakeGithubApi
211212
Paths_taskrunner
212213
autogen-modules:
213214
Paths_taskrunner
@@ -291,5 +292,7 @@ test-suite taskrunner-test
291292
, transformers
292293
, universum
293294
, unix
295+
, wai
296+
, warp
294297
, zstd
295298
default-language: Haskell2010

‎test/FakeGithubApi.hs‎

Lines changed: 72 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,72 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE RecursiveDo #-}
3+
4+
module FakeGithubApi (Server, start, stop, clearOutput, getOutput) where
5+
6+
import Universum
7+
8+
import Network.Wai
9+
import qualified Network.Wai.Handler.Warp as Warp
10+
import Network.HTTP.Types (status200, status201, status400, status404, methodPost)
11+
import Data.Aeson (encode, object, (.=))
12+
13+
import Control.Concurrent (forkIO, ThreadId, killThread)
14+
15+
-- Mock handler function
16+
app :: Server -> Application
17+
app server req respond = do
18+
let path = pathInfo req
19+
case path of
20+
["app", "installations", instId, "access_tokens"] ->
21+
handleAccessTokenRequest server instId req respond
22+
["repos", owner, repo, "statuses", commitSha] ->
23+
handleCommitStatusRequest server owner repo commitSha req respond
24+
_ -> respond $ responseLBS status404 [] "Not Found"
25+
26+
handleAccessTokenRequest :: Server -> Text -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
27+
handleAccessTokenRequest server instId req respond =
28+
if requestMethod req == methodPost
29+
then do
30+
addOutput server $ "Requested access token for installation " <> instId
31+
respond $ responseLBS status200 [("Content-Type", "application/json")]
32+
(encode $ object ["token" .= ("mock-access-token" :: Text), "installation_id" .= instId])
33+
else respond $ responseLBS status400 [] "Bad Request"
34+
35+
handleCommitStatusRequest :: Server -> Text -> Text -> Text -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
36+
handleCommitStatusRequest server owner repo commitSha req respond =
37+
if requestMethod req == methodPost
38+
then do
39+
body <- strictRequestBody req
40+
-- Note: commit SHA omitted because it's nondeterministic
41+
addOutput server $ "Updated commit status for " <> owner <> "/" <> repo <> " to " <> decodeUtf8 body
42+
respond $ responseLBS status201 [("Content-Type", "application/json")]
43+
(encode $ object ["state" .= ("success" :: Text), "sha" .= commitSha, "repository" .= repo, "owner" .= owner])
44+
else respond $ responseLBS status400 [] "Bad Request"
45+
46+
data Server = Server
47+
{ tid :: ThreadId
48+
, output :: IORef [Text]
49+
}
50+
51+
start :: Int -> IO Server
52+
start port = do
53+
started <- newEmptyMVar
54+
output <- newIORef []
55+
let settings = Warp.setPort port $ Warp.setBeforeMainLoop (putMVar started ()) Warp.defaultSettings
56+
rec
57+
let server = Server {tid, output}
58+
tid <- forkIO $ Warp.runSettings settings $ app server
59+
takeMVar started
60+
pure server
61+
62+
stop :: Server -> IO ()
63+
stop (Server {tid}) = killThread tid
64+
65+
addOutput :: Server -> Text -> IO ()
66+
addOutput (Server {output}) msg = modifyIORef output (msg :)
67+
68+
clearOutput :: Server -> IO ()
69+
clearOutput (Server {output}) = writeIORef output []
70+
71+
getOutput :: Server -> IO [Text]
72+
getOutput (Server {output}) = reverse <$> readIORef output

0 commit comments

Comments
 (0)