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

git.iko.soy/sc-build

changed config to yaml

commit4597fdc5d8edee03f907786a42694ae07ec33df1 authoriko <ilyakooo0@gmail.com> dateMon 24 Feb 2020, 13:58 (7 years ago) parenteb15496

5 files changed+94−55

compare with master

unifiedsplit

package.yaml+1 src/Control/GithubCloner.hs+4−10 src/Data/Tasks/Build.hs+3−4 src/Server.hs+27−9 src/Server/Config.hs+59−32

package.yaml+1

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

1717library:

1818 source-dirs: src

1919 dependencies:

20+ - http-client-tls

2021 - servant

2122 - servant-server

2223 - process

src/Control/GithubCloner.hs+4−10

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

11module Control.GithubCloner

2− ( GithubAccessToken (..),

3− GithubUserName (..),

4− GithubCloner (..),

2+ ( GithubCloner (..),

3+ InstallationToken (..),

54 )

65where

8−newtype GithubAccessToken = GithubAccessToken String

9−

10−newtype GithubUserName = GithubUserName String

7+newtype InstallationToken = InstallationToken String

118

129class GithubCloner m where

13−

14− getGithubAccessToken :: m GithubAccessToken

15−

16− getGithubUserName :: m GithubUserName

10+ getGithubInstallationToken :: m InstallationToken

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

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

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

4747

4848instance 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)

5050

5151 performTask Build {..} =

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

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

190190

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

192192cloneRepo repoName sha path = do

193− GithubAccessToken token <- getGithubAccessToken

194− GithubUserName username <- getGithubUserName

193+ InstallationToken token <- getGithubInstallationToken

195194 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 ."

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

198197 return ()

199198

src/Server.hs+27−9

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

1414import Control.Monad.IO.Unlift

1515import Control.Monad.Reader

1616import Control.Task.Scheduler

17+import Crypto.PubKey.RSA.Read

1718import Data.Aeson

1819import 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

1923import qualified Data.Csv as Csv

2024import Data.IORef

2125import Data.Map (Map)

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

3034import GitHub hiding (Accept)

3135import GitHub.App.Auth

3236import GitHub.App.Request

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

3338import GitHub.Data.Name

3439import GitHub.Data.Webhooks.Events

3540import GitHub.Data.Webhooks.Payload

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

3642import Network.HTTP.Media.MediaType

3743import Network.Wai.Handler.Warp

3844import Servant

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

4450import Squeal.PostgreSQL

4551import System.IO

4652import Text.Blaze.Html

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

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

4854

4955type API =

5056 "github-webhook"

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

161167runServer = do

162168 c@Config {..} <- getConfig

163169 print c

170+ pem <- BS.readFile appPkPemPath

171+ appPkPem <- case readRsaPem pem of

172+ Right k -> return k

173+ Left e -> error (show e)

164174 auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId

165175 ts <- newIORef mempty

166176 pool <- createConnectionPool databseUrl 1 0.5 10

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

173183 serverData =

174184 ServerData

175185 { githubAppAuth = auth,

176− githubUserName = GithubUserName githubUsername,

177− githubAccessToken = GithubAccessToken personalAccessToken,

178186 tasks = ts,

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

180188 baseUrl = baseSiteUrl,

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

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

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

185193 repeatIfNotEmpty n f

194+ printingErrors =

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

186196 _ <-

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

188198 . usingConnectionPool pool

189199 . (`runReaderT` serverData)

190200 . unApp

201+ . printingErrors

191202 $ runTasks @'[Build] 1

192203 _ <-

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

194205 . usingConnectionPool pool

195206 . (`runReaderT` serverData)

196207 . unApp

208+ . printingErrors

197209 $ runTasks @'[StatusUpdate] 5

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

199211 hoistServerWithContext

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

211223data ServerData m

212224 = ServerData

213225 { githubAppAuth :: !InstallationAuth,

214− githubUserName :: !GithubUserName,

215− githubAccessToken :: !GithubAccessToken,

216226 tasks :: IORef TasksConfig,

217227 logger :: LogAction m Message,

218228 baseUrl :: String,

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

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

228238 getContextEntry (PolyGitHubKey x :. _) = x

229239

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

231− getGithubAccessToken = asks githubAccessToken

232−

233− getGithubUserName = asks githubUserName

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

241+ getGithubInstallationToken =

242+ either

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."

234252

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

236254 appRequest req = do

src/Server/Config.hs+59−32

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

33module Server.Config

44 ( Config (..),

5+ defaultConfig,

56 getConfig,

67 )

78where

910import Colog

10−import Crypto.PubKey.RSA (PrivateKey)

1111import Crypto.PubKey.RSA.Read

12−import Data.ByteString as BS

13−import qualified Data.ByteString.Char8 as BS8

14−import Data.Maybe

12+import Data.Aeson as A

13+import Data.ByteString.Char8 as BS

14+import Data.Text as T

15+import Data.Yaml

16+import GHC.Generics

1517import GitHub.Data.Apps

1618import GitHub.Data.Id

1719import GitHub.Data.Installations

18−import System.Environment

20+import Text.Read (readMaybe)

1921

2022data Config

2123 = Config

2224 { webhookSecret :: !ByteString,

2325 appId :: !(Id App),

24− appPkPem :: !PrivateKey,

26+ appPkPemPath :: !FilePath,

2527 port :: !Int,

2628 installationId :: !(Id Installation),

27− personalAccessToken :: !String,

28− githubUsername :: !String,

2929 tasksPath :: !FilePath,

3030 databseUrl :: !ByteString,

3131 baseSiteUrl :: !String,

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

3333 cfgDockerFile :: !FilePath,

3434 logSeverity :: !Severity

3535 }

36− deriving (Show)

36+ deriving (Show, Generic)

3737

38−getConfig :: IO Config

39−getConfig =

38+instance FromJSON ByteString where

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 =

4050 Config

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

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

43− <*> readPem

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

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

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

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

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")

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

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

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

54− where

55− readPem :: IO PrivateKey

56− readPem = do

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

58− pem <- BS.readFile path

59− case readRsaPem pem of

60− Right k -> return k

61− Left e -> error (show e)

51+ { webhookSecret = "GITHUB SECRET",

52+ appId = Id 69,

53+ appPkPemPath = "PRIVATE KEY PATH",

54+ port = 8080,

55+ installationId = Id 69,

56+ tasksPath = "TASKS PATH",

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

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")

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

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

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

81+-- where

82+-- readPem :: IO PrivateKey

83+-- readPem = do

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

85+-- pem <- BS.readFile path

86+-- case readRsaPem pem of

87+-- Right k -> return k

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

6289

6390deriving instance Show ReadRsaKeyError