11eeda3 · sc-build · git.iko.soy

git.iko.soy/sc-build

added name option

commit11eeda36b4b52ff359b1c8e2450a4562a4699af3 authoriko <ilyakooo0@gmail.com> dateMon 24 Feb 2020, 16:14 (7 years ago) parenta2edc92

6 files changed+95−49

compare with master

unifiedsplit

src/Control/HasGithubStatus.hs+13 src/Data/Tasks/Build.hs+13−32 src/Data/Tasks/StatusUpdate.hs−1 src/Server.hs+61−11 src/Server/Config.hs+5−3 src/Server/Html.hs+3−2

src/Control/HasGithubStatus.hsnew file+13

@@ -0,0 +1,13 @@

1+module Control.HasGithubStatus

2+ ( HasGithubStatus (..),

3+ )

4+where

6+import Colog

7+import Data.Submission

8+import GitHub.Data

10+class HasGithubStatus m where

11+ schedulePendingStatus :: WithLog env Message m => Name Owner -> Name Repo -> Name Commit -> m ()

12+ scheduleTestedStatus :: WithLog env Message m => TestResult -> Name Owner -> Name Repo -> Name Commit -> m ()

13+ scheduleFailedStatus :: WithLog env Message m => String -> Name Owner -> Name Repo -> Name Commit -> m ()

src/Data/Tasks/Build.hs+13−32

@@ -10,17 +10,15 @@ where

1010import Colog

1111import Control.Concurrent

1212import Control.GithubCloner

13+import Control.HasGithubStatus

1314import Control.Monad.Except

1415import Control.Monad.IO.Unlift

1516import Control.Task

16−import Control.Task.Scheduler

1717import Data.Aeson hiding (Success)

1818import qualified Data.ByteString.Lazy.Char8 as BS

19−import qualified Data.Map as M

2019import Data.String

2120import Data.Submission

2221import Data.Submission.Query

23−import Data.Tasks.StatusUpdate

2422import qualified Data.Text as T

2523import Data.Time.Clock.POSIX

2624import qualified Docker.Client as D

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

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

4745

4846instance Task Build "build-repo" where

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

47+ type

48+ TaskMonad Build m =

49+ (MonadUnliftIO m, StaticPQ m, HasDockerInfo m, GithubCloner m, HasGithubStatus m)

5050

5151 performTask Build {..} =

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

@@ -62,7 +62,7 @@ instance Task Build "build-repo" where

6262 <> show n

6363 <> " and error "

6464 <> err

65− scheduleTask erroredTask

65+ scheduleFailedStatus err owner repoName sha

6666 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

6767 ExitSuccess -> do

6868 h <- liftIO D.defaultHttpHandler

@@ -73,7 +73,8 @@ instance Task Build "build-repo" where

7373 Exception err,

7474 WithLog env Message m,

7575 StaticPQ m,

76− MonadUnliftIO m

76+ MonadUnliftIO m,

77+ HasGithubStatus m

7778 ) =>

7879 D.DockerT IO (Either err a) ->

7980 m a

@@ -124,7 +125,7 @@ instance Task Build "build-repo" where

124125 <> show n

125126 <> " and error "

126127 <> err

127− scheduleTask erroredTask

128+ scheduleFailedStatus err owner repoName sha

128129 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

129130 (ExitSuccess, buildOut) ->

130131 case eitherDecode' (BS.dropWhile (/= '{') buildOut) of

@@ -136,48 +137,28 @@ instance Task Build "build-repo" where

136137 <> show sha

137138 <> ": "

138139 <> err

139− scheduleTask erroredTask

140+ scheduleFailedStatus err owner repoName sha

140141 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

141142 Right testResult@TestResult {..} -> do

142− let total = M.size tests

143− passed = M.size . M.filter id $ tests

144− description = T.pack $ show passed <> "/" <> show total

145− status =

146− statusTask

147− NewStatus

148− { newStatusState =

149− if total == passed then StatusSuccess else StatusFailure,

150− newStatusTargetUrl = Nothing,

151− newStatusDescription = Just description,

152− newStatusContext = Nothing

153− }

154− scheduleTask status

143+ scheduleTestedStatus testResult owner repoName sha

155144 updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)

156145 return Success

157146 where

158− statusTask = StatusUpdate owner repoName sha

159− erroredTask =

160− statusTask $

161− NewStatus

162− { newStatusState = StatusError,

163− newStatusTargetUrl = Nothing,

164− newStatusDescription = Just "Build failed",

165− newStatusContext = Nothing

166− }

167147 fullRepoName = T.unpack $ untagName owner <> "/" <> untagName repoName

168148 sha' = T.unpack $ untagName sha

169149 runEither ::

170150 ( Exception err,

171151 WithLog env Message m,

172152 StaticPQ m,

173− MonadUnliftIO m

153+ MonadUnliftIO m,

154+ HasGithubStatus m

174155 ) =>

175156 Either err b ->

176157 m b

177158 runEither (Left err) = do

178159 let err' = show err

179160 logError $ T.pack err'

180− scheduleTask erroredTask

161+ scheduleFailedStatus err' owner repoName sha

181162 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err')

182163 throwIO err

183164 runEither (Right a) = return a

src/Data/Tasks/StatusUpdate.hs−1

@@ -31,7 +31,6 @@ instance FromJSON NewStatus where

3131 <*> v .:? "context"

3232

3333instance Task StatusUpdate "update-commit-ci-status" where

34−

3534 type TaskMonad StatusUpdate m = (AppRequestable m)

3635

3736 performTask StatusUpdate {..} = do

src/Server.hs+61−11

@@ -10,6 +10,7 @@ import Colog

1010import Control.AppRequestable

1111import Control.Concurrent

1212import Control.GithubCloner

13+import Control.HasGithubStatus

1314import Control.Monad.Except

1415import Control.Monad.IO.Unlift

1516import Control.Monad.Reader

@@ -37,7 +38,7 @@ import GitHub.App.Request

3738import GitHub.Auth (Auth (OAuth))

3839import GitHub.Data.Name

3940import GitHub.Data.Webhooks.Events

40−import GitHub.Data.Webhooks.Payload

41+import GitHub.Data.Webhooks.Payload hiding (URL (..))

4142import Network.HTTP.Client.TLS (newTlsManager)

4243import Network.HTTP.Media.MediaType

4344import Network.Wai.Handler.Warp

@@ -80,11 +81,8 @@ webhookInstallation _ ((), ev) =

8081 print ev

8182 hFlush stdout

8283

83−pendingStatus :: NewStatus

84−pendingStatus = NewStatus StatusPending Nothing Nothing Nothing

85−

8684webhookPushEvent ::

87− (StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m, MonadError ServerError m) =>

85+ (StaticPQ m, MonadReader (ServerData m) m, MonadUnliftIO m, HasTasks m, MonadError ServerError m) =>

8886 RepoWebhookEvent ->

8987 ((), PushEvent) ->

9088 m ()

@@ -102,7 +100,7 @@ webhookPushEvent _ ((), ev) = do

102100 M.takeWhileAntitone (repoName >) tasks

103101 case task of

104102 Just (name, TaskConfig {..}) | T.take (T.length name) repoName == name -> do

105− scheduleTask $ StatusUpdate (N owner) (N repoName) (N sha) pendingStatus

103+ schedulePendingStatus (N owner) (N repoName) (N sha)

106104 createSubmission $

107105 Submission

108106 user

@@ -117,7 +115,7 @@ webhookPushEvent _ ((), ev) = do

117115 _ -> return ()

118116

119117retestSubmission ::

120− (StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m, MonadHasBaseUrl m) =>

118+ (StaticPQ m, MonadReader (ServerData m) m, MonadUnliftIO m, HasTasks m, MonadHasBaseUrl m) =>

121119 String ->

122120 String ->

123121 String ->

@@ -136,7 +134,7 @@ retestSubmission owner repoName sha = do

136134 M.takeWhileAntitone (repoName' >) tasks

137135 case task of

138136 Just (name, TaskConfig {..}) | T.take (T.length name) repoName' == name -> do

139− scheduleTask $ StatusUpdate (N owner') (N repoName') (N sha') pendingStatus

137+ schedulePendingStatus (N owner') (N repoName') (N sha')

140138 updateSubmissionStatus fullRepoName sha BuildScheduled

141139 scheduleTask $ Build prebuild dockerfile (N owner') (N repoName') (N sha') timeoutMinutes

142140 _ -> return ()

@@ -186,7 +184,8 @@ runServer = do

186184 tasks = ts,

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

188186 baseUrl = baseSiteUrl,

189− dockerUrl = T.pack cfgDockerUrl

187+ dockerUrl = T.pack cfgDockerUrl,

188+ context = githubContext

190189 }

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

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

@@ -230,8 +229,9 @@ data ServerData m

230229 { githubAppAuth :: !InstallationAuth,

231230 tasks :: IORef TasksConfig,

232231 logger :: LogAction m Message,

233− baseUrl :: String,

234− dockerUrl :: T.Text

232+ baseUrl :: T.Text,

233+ dockerUrl :: T.Text,

234+ context :: T.Text

235235 }

236236

237237newtype PolyGitHubKey = PolyGitHubKey (forall result. GitHubKey result)

@@ -266,6 +266,56 @@ instance MonadReader (ServerData n) m => MonadHasBaseUrl m where

266266instance (MonadIO m, MonadReader (ServerData n) m) => HasTasks m where

267267 getTasks = asks tasks >>= liftIO . readIORef

268268

269+instance (MonadReader (ServerData m) m, StaticPQ m, MonadUnliftIO m) => HasGithubStatus m where

270+ schedulePendingStatus nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do

271+ h <- asks baseUrl

272+ c <- asks context

273+ scheduleTask $

274+ StatusUpdate

275+ nOwner

276+ nRepo

277+ nCommit

278+ ( NewStatus

279+ StatusPending

280+ (Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha)

281+ Nothing

282+ (Just c)

283+ )

284+ scheduleTestedStatus TestResult {..} nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do

285+ h <- asks baseUrl

286+ c <- asks context

287+ let total = M.size tests

288+ passed = M.size . M.filter id $ tests

289+ description = T.pack $ show passed <> "/" <> show total

290+ status =

291+ StatusUpdate

292+ nOwner

293+ nRepo

294+ nCommit

295+ NewStatus

296+ { newStatusState =

297+ if total == passed then StatusSuccess else StatusFailure,

298+ newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,

299+ newStatusDescription = Just description,

300+ newStatusContext = Just c

301+ }

302+ scheduleTask status

303+ scheduleFailedStatus _ nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do

304+ h <- asks baseUrl

305+ c <- asks context

306+ let status =

307+ StatusUpdate

308+ nOwner

309+ nRepo

310+ nCommit

311+ NewStatus

312+ { newStatusState = StatusError,

313+ newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,

314+ newStatusDescription = Just "Build failed",

315+ newStatusContext = Just c

316+ }

317+ scheduleTask status

318+

269319instance (MonadReader (ServerData n) m) => HasDockerInfo m where

270320 getDockerUrl = asks dockerUrl

271321

src/Server/Config.hs+5−3

@@ -28,11 +28,12 @@ data Config

2828 installationId :: !(Id Installation),

2929 tasksPath :: !FilePath,

3030 databseUrl :: !ByteString,

31− baseSiteUrl :: !String,

31+ baseSiteUrl :: !Text,

3232 cfgDockerUrl :: !String,

3333 cfgDockerFile :: !FilePath,

3434 logSeverity :: !Severity,

35− builderCount :: !Int

35+ builderCount :: !Int,

36+ githubContext :: !Text

3637 }

3738 deriving (Show, Generic)

3839

@@ -68,7 +69,8 @@ defaultConfig =

6869 cfgDockerUrl = "http://localhost:1234",

6970 cfgDockerFile = "TmpDockerfile",

7071 logSeverity = Info,

71− builderCount = 2

72+ builderCount = 2,

73+ githubContext = "MY CI NAME"

7274 }

7375

7476getConfig :: IO Config

src/Server/Html.hs+3−2

@@ -16,6 +16,7 @@ import qualified Data.Map as M

1616import Data.String

1717import Data.Submission

1818import Data.Submission.Query

19+import qualified Data.Text as T

1920import Server.Schema

2021import Squeal.PostgreSQL (Jsonb (..))

2122import Text.Blaze

@@ -91,12 +92,12 @@ getSubmissionR user repo sha' = do

9192 H.body inner

9293

9394class MonadHasBaseUrl m where

94− getBaseUrl :: m String

95+ getBaseUrl :: m T.Text

9596

9697getUrl :: (MonadHasBaseUrl m, Monad m) => String -> String -> m String

9798getUrl fullName sha = do

9899 siteBase <- getBaseUrl

99− return $ siteBase <> "/submission/" <> fullName <> "/" <> sha

100+ return $ T.unpack siteBase <> "/submission/" <> fullName <> "/" <> sha

100101

101102redirectToSubmission ::

102103 (MonadHasBaseUrl m, Monad m) =>