4597fdc · sc-build · git.iko.soy

git.iko.soy/sc-build

on master help sign in

changed config to yaml

4597fdciko7 years ago

package.yaml+1

compare with master

unifiedsplit

@@ -17,6 +17,7 @@ dependencies:

17library:

18 source-dirs: src

19 dependencies:

20+ - http-client-tls

20 - servant

21 - servant

21 - servant-server

22 - servant-server

22 - process

23 - process

src/Control/GithubCloner.hs+4−10

@@ -1,16 +1,10 @@

1module Control.GithubCloner

2− ( GithubAccessToken (..),

3− GithubUserName (..),

4− GithubCloner (..),

2+ ( GithubCloner (..),

3+ InstallationToken (..),

5 )

4 )

6where

5where

8−newtype GithubAccessToken = GithubAccessToken String

7+newtype InstallationToken = InstallationToken String

9−

10−newtype GithubUserName = GithubUserName String

12class GithubCloner m where

9class GithubCloner m where

13−

10+ getGithubInstallationToken :: m InstallationToken

14− getGithubAccessToken :: m GithubAccessToken

15−

16− getGithubUserName :: m GithubUserName

src/Data/Tasks/Build.hs+3−4

@@ -46,7 +46,7 @@ data Build

46 deriving (Eq, Show, Generic, FromJSON, ToJSON)

48instance Task Build "build-repo" where

49− type TaskMonad Build m = (MonadUnliftIO m, GithubCloner m, StaticPQ m, HasDockerInfo m)

49+ type TaskMonad Build m = (MonadUnliftIO m, StaticPQ m, HasDockerInfo m, GithubCloner m)

51 performTask Build {..} =

52 bracket createDir (liftIO . removePathForcibly) $ \dir -> flip catchAny (const $ return Failure) $ do

@@ -190,10 +190,9 @@ createDir = do

190

191cloneRepo :: (MonadIO m, GithubCloner m) => String -> String -> FilePath -> m ()

192cloneRepo repoName sha path = do

193− GithubAccessToken token <- getGithubAccessToken

193+ InstallationToken token <- getGithubInstallationToken

194− GithubUserName username <- getGithubUserName

195 runProcess_ . setWorkingDir path . fromString $

194 runProcess_ . setWorkingDir path . fromString $

196− "git clone https://" <> username <> ":" <> token <> "@github.com/" <> repoName <> ".git ."

195+ "git clone https://x-access-token:" <> token <> "@github.com/" <> repoName <> ".git ."

197 runProcess_ . setWorkingDir path . fromString $ "git checkout " <> sha

196 runProcess_ . setWorkingDir path . fromString $ "git checkout " <> sha

198 return ()

197 return ()

199

198

src/Server.hs+27−9

@@ -14,8 +14,12 @@ import Control.Monad.Except

14import Control.Monad.IO.Unlift

15import Control.Monad.Reader

16import Control.Task.Scheduler

17+import Crypto.PubKey.RSA.Read

17import Data.Aeson

18import Data.Aeson

18import Data.ByteString

19import Data.ByteString

20+import qualified Data.ByteString as BS

21+import qualified Data.ByteString.Char8 as BSC

22+import qualified Data.ByteString.Lazy.Char8 as BSCL

19import qualified Data.Csv as Csv

23import qualified Data.Csv as Csv

20import Data.IORef

24import Data.IORef

21import Data.Map (Map)

25import Data.Map (Map)

@@ -30,9 +34,11 @@ import GHC.Generics

30import GitHub hiding (Accept)

34import GitHub hiding (Accept)

31import GitHub.App.Auth

35import GitHub.App.Auth

32import GitHub.App.Request

36import GitHub.App.Request

37+import GitHub.Auth (Auth (OAuth))

33import GitHub.Data.Name

38import GitHub.Data.Name

34import GitHub.Data.Webhooks.Events

39import GitHub.Data.Webhooks.Events

35import GitHub.Data.Webhooks.Payload

40import GitHub.Data.Webhooks.Payload

41+import Network.HTTP.Client.TLS (newTlsManager)

36import Network.HTTP.Media.MediaType

42import Network.HTTP.Media.MediaType

37import Network.Wai.Handler.Warp

43import Network.Wai.Handler.Warp

38import Servant

44import Servant

@@ -44,7 +50,7 @@ import Server.Schema

44import Squeal.PostgreSQL

50import Squeal.PostgreSQL

45import System.IO

51import System.IO

46import Text.Blaze.Html

52import Text.Blaze.Html

47−import UnliftIO.Exception (catch, throwIO, try)

53+import UnliftIO.Exception (catch, displayException, handleAny, throwIO, try)

49type API =

55type API =

50 "github-webhook"

56 "github-webhook"

@@ -161,6 +167,10 @@ runServer :: IO ()

161runServer = do

167runServer = do

162 c@Config {..} <- getConfig

168 c@Config {..} <- getConfig

163 print c

169 print c

170+ pem <- BS.readFile appPkPemPath

171+ appPkPem <- case readRsaPem pem of

172+ Right k -> return k

173+ Left e -> error (show e)

164 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

174 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

165 ts <- newIORef mempty

175 ts <- newIORef mempty

166 pool <- createConnectionPool databseUrl 1 0.5 10

176 pool <- createConnectionPool databseUrl 1 0.5 10

@@ -173,8 +183,6 @@ runServer = do

173 serverData =

183 serverData =

174 ServerData

184 ServerData

175 { githubAppAuth = auth,

185 { githubAppAuth = auth,

176− githubUserName = GithubUserName githubUsername,

177− githubAccessToken = GithubAccessToken personalAccessToken,

178 tasks = ts,

186 tasks = ts,

179 logger = cfilter ((logSeverity <=) . msgSeverity) richMessageAction,

187 logger = cfilter ((logSeverity <=) . msgSeverity) richMessageAction,

180 baseUrl = baseSiteUrl,

188 baseUrl = baseSiteUrl,

@@ -183,17 +191,21 @@ runServer = do

183 repeatIfNotEmpty n f = f >>= \m -> do

191 repeatIfNotEmpty n f = f >>= \m -> do

184 when (m == 0) $ liftIO $ threadDelay n

192 when (m == 0) $ liftIO $ threadDelay n

185 repeatIfNotEmpty n f

193 repeatIfNotEmpty n f

194+ printingErrors =

195+ handleAny (logError . T.pack . displayException >=> const (return 0))

186 _ <-

196 _ <-

187 forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))

197 forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))

188 . usingConnectionPool pool

198 . usingConnectionPool pool

189 . (`runReaderT` serverData)

199 . (`runReaderT` serverData)

190 . unApp

200 . unApp

201+ . printingErrors

191 $ runTasks @'[Build] 1

202 $ runTasks @'[Build] 1

192 _ <-

203 _ <-

193 forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))

204 forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))

194 . usingConnectionPool pool

205 . usingConnectionPool pool

195 . (`runReaderT` serverData)

206 . (`runReaderT` serverData)

196 . unApp

207 . unApp

208+ . printingErrors

197 $ runTasks @'[StatusUpdate] 5

209 $ runTasks @'[StatusUpdate] 5

198 run port $ serveWithContext (Proxy @API) context $

210 run port $ serveWithContext (Proxy @API) context $

199 hoistServerWithContext

211 hoistServerWithContext

@@ -211,8 +223,6 @@ updateTasks ref path =

211data ServerData m

223data ServerData m

212 = ServerData

224 = ServerData

213 { githubAppAuth :: !InstallationAuth,

225 { githubAppAuth :: !InstallationAuth,

214− githubUserName :: !GithubUserName,

215− githubAccessToken :: !GithubAccessToken,

216 tasks :: IORef TasksConfig,

226 tasks :: IORef TasksConfig,

217 logger :: LogAction m Message,

227 logger :: LogAction m Message,

218 baseUrl :: String,

228 baseUrl :: String,

@@ -227,10 +237,18 @@ gitPolyHubKey k = PolyGitHubKey (Servant.GitHub.Webhook.gitHubKey k)

227instance HasContextEntry '[PolyGitHubKey] (GitHubKey result) where

237instance HasContextEntry '[PolyGitHubKey] (GitHubKey result) where

228 getContextEntry (PolyGitHubKey x :. _) = x

238 getContextEntry (PolyGitHubKey x :. _) = x

229

239

230−instance MonadReader (ServerData n) m => GithubCloner m where

240+instance (MonadReader (ServerData n) m, MonadIO m, MonadError ServerError m) => GithubCloner m where

231− getGithubAccessToken = asks githubAccessToken

241+ getGithubInstallationToken =

232−

242+ either

233− getGithubUserName = asks githubUserName

243+ (\e -> throwError err500 {errBody = BSCL.pack . displayException $ e})

244+ return

245+ <=< runExceptT

246+ $ do

247+ iAuth <- asks githubAppAuth

248+ manager <- newTlsManager

249+ liftIO (obtainAccessToken manager iAuth) >>= either throwError return >>= \case

250+ OAuth token -> return $ InstallationToken (BSC.unpack token)

251+ _ -> throwError $ UserError "Not OAuth token. This should never happen."

234

252

235instance (MonadIO m, MonadReader (ServerData n) m) => AppRequestable m where

253instance (MonadIO m, MonadReader (ServerData n) m) => AppRequestable m where

236 appRequest req = do

254 appRequest req = do

src/Server/Config.hs+59−32

@@ -2,30 +2,30 @@

3module Server.Config

4 ( Config (..),

5+ defaultConfig,

5 getConfig,

6 getConfig,

6 )

7 )

7where

8where

9import Colog

10import Colog

10−import Crypto.PubKey.RSA (PrivateKey)

11import Crypto.PubKey.RSA.Read

12−import Data.ByteString as BS

12+import Data.Aeson as A

13−import qualified Data.ByteString.Char8 as BS8

13+import Data.ByteString.Char8 as BS

14+import Data.Text as T

14−import Data.Maybe

15+import Data.Yaml

16+import GHC.Generics

15import GitHub.Data.Apps

17import GitHub.Data.Apps

16import GitHub.Data.Id

18import GitHub.Data.Id

17import GitHub.Data.Installations

19import GitHub.Data.Installations

18−import System.Environment

20+import Text.Read (readMaybe)

20data Config

22data Config

21 = Config

23 = Config

22 { webhookSecret :: !ByteString,

24 { webhookSecret :: !ByteString,

23 appId :: !(Id App),

25 appId :: !(Id App),

24− appPkPem :: !PrivateKey,

26+ appPkPemPath :: !FilePath,

25 port :: !Int,

27 port :: !Int,

26 installationId :: !(Id Installation),

28 installationId :: !(Id Installation),

27− personalAccessToken :: !String,

28− githubUsername :: !String,

29 tasksPath :: !FilePath,

30 databseUrl :: !ByteString,

31 baseSiteUrl :: !String,

@@ -33,31 +33,58 @@ data Config

33 cfgDockerFile :: !FilePath,

34 logSeverity :: !Severity

35 }

36− deriving (Show)

36+ deriving (Show, Generic)

38−getConfig :: IO Config

38+instance FromJSON ByteString where

39−getConfig =

39+ parseJSON (String s) = return . BS.pack . T.unpack $ s

40+ parseJSON _ = fail "not a string"

41+

42+instance FromJSON Severity where

43+ parseJSON (String s) = maybe (fail "oh no") return . readMaybe . T.unpack $ s

44+ parseJSON _ = fail "not a string"

45+

46+instance FromJSON Config

47+

48+defaultConfig :: Config

49+defaultConfig =

40 Config

50 Config

41− <$> (maybe (error "no GITHUB_WEBHOOK_SECRET") BS8.pack <$> lookupEnv "GITHUB_WEBHOOK_SECRET")

51+ { webhookSecret = "GITHUB SECRET",

42− <*> (maybe (error "no GITHUB_APP_ID") (Id . read) <$> lookupEnv "GITHUB_APP_ID")

52+ appId = Id 69,

43− <*> readPem

53+ appPkPemPath = "PRIVATE KEY PATH",

44− <*> (maybe 8080 read <$> lookupEnv "PORT")

54+ port = 8080,

45− <*> (maybe (error "no GITHUB_INSTALLATION_ID") (Id . read) <$> lookupEnv "GITHUB_INSTALLATION_ID")

55+ installationId = Id 69,

46− <*> (fromMaybe (error "no PERSONAL_ACCESS_TOKEN") <$> lookupEnv "PERSONAL_ACCESS_TOKEN")

56+ tasksPath = "TASKS PATH",

47− <*> (fromMaybe (error "no GITHUB_USERNAME") <$> lookupEnv "GITHUB_USERNAME")

57+ databseUrl = "host=localhost port=5432 dbname=sc-build connect_timeout=10",

48− <*> (fromMaybe (error "no TASKS") <$> lookupEnv "TASKS")

49− <*> (maybe (error "no DATABASE_URL") BS8.pack <$> lookupEnv "DATABASE_URL")

50− <*> (fromMaybe "http://localhost:8080" <$> lookupEnv "PORT")

58+ baseSiteUrl = "http://localhost:8080",

59+ cfgDockerUrl = "http://localhost:1234",

60+ cfgDockerFile = "TmpDockerfile",

61+ logSeverity = Info

62+ }

63+

64+getConfig :: IO Config

65+getConfig = decodeThrow "config.yaml"

66+

67+-- getConfig :: IO Config

68+-- getConfig =

69+-- Config

70+-- <$> (maybe (error "no GITHUB_WEBHOOK_SECRET") BS8.pack <$> lookupEnv "GITHUB_WEBHOOK_SECRET")

71+-- <*> (maybe (error "no GITHUB_APP_ID") (Id . read) <$> lookupEnv "GITHUB_APP_ID")

72+-- <*> readPem

73+-- <*> (maybe 8080 read <$> lookupEnv "PORT")

74+-- <*> (maybe (error "no GITHUB_INSTALLATION_ID") (Id . read) <$> lookupEnv "GITHUB_INSTALLATION_ID")

75+-- <*> (fromMaybe (error "no TASKS") <$> lookupEnv "TASKS")

76+-- <*> (maybe (error "no DATABASE_URL") BS8.pack <$> lookupEnv "DATABASE_URL")

77+-- <*> (fromMaybe "http://localhost:8080" <$> lookupEnv "PORT")

51− <*> (fromMaybe "http://localhost:1234" <$> lookupEnv "DOCKER_URL")

78+-- <*> (fromMaybe <$> lookupEnv "DOCKER_URL")

52− <*> (fromMaybe "TmpDockerfile" <$> lookupEnv "DOCKER_FILE")

79+-- <*> (fromMaybe "TmpDockerfile" <$> lookupEnv "DOCKER_FILE")

53− <*> (maybe Info read <$> lookupEnv "LOG_SEVERITY")

80+-- <*> (maybe Info read <$> lookupEnv "LOG_SEVERITY")

54− where

81+-- where

55− readPem :: IO PrivateKey

82+-- readPem :: IO PrivateKey

56− readPem = do

83+-- readPem = do

57− path <- fromMaybe (error "no app pk") <$> lookupEnv "GITHUB_APP_PK"

84+-- path <- fromMaybe (error "no app pk") <$> lookupEnv "GITHUB_APP_PK"

58− pem <- BS.readFile path

85+-- pem <- BS.readFile path

59− case readRsaPem pem of

86+-- case readRsaPem pem of

60− Right k -> return k

87+-- Right k -> return k

61− Left e -> error (show e)

88+-- Left e -> error (show e)

63deriving instance Show ReadRsaKeyError

90deriving instance Show ReadRsaKeyError