ilyakooo0/sc-build
1
0
Fork 0
mirror of https://github.com/ilyakooo0/sc-build.git synced 2024-11-27 09:37:30 +03:00
Code Issues Projects Releases Wiki Activity

added name option

Browse Source
This commit is contained in:
iko 2020-02-24 16:14:35 +03:00
parent a2edc92ed5
commit 11eeda36b4
6 changed files with 95 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
src/Control/HasGithubStatus.hs Normal file
View File

@ -0,0 +1,13 @@
module Control.HasGithubStatus
( HasGithubStatus (..),
)
where
import Colog
import Data.Submission
import GitHub.Data
class HasGithubStatus m where
schedulePendingStatus :: WithLog env Message m => Name Owner -> Name Repo -> Name Commit -> m ()
scheduleTestedStatus :: WithLog env Message m => TestResult -> Name Owner -> Name Repo -> Name Commit -> m ()
scheduleFailedStatus :: WithLog env Message m => String -> Name Owner -> Name Repo -> Name Commit -> m ()

45
src/Data/Tasks/Build.hs
View File

@ -10,17 +10,15 @@ where
import Colog
import Control.Concurrent
import Control.GithubCloner
import Control.HasGithubStatus
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Task
import Control.Task.Scheduler
import Data.Aeson hiding (Success)
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.Map as M
import Data.String
import Data.Submission
import Data.Submission.Query
import Data.Tasks.StatusUpdate
import qualified Data.Text as T
import Data.Time.Clock.POSIX
import qualified Docker.Client as D
@ -46,7 +44,9 @@ data Build
deriving (Eq, Show, Generic, FromJSON, ToJSON)
instance Task Build "build-repo" where
type TaskMonad Build m = (MonadUnliftIO m, StaticPQ m, HasDockerInfo m, GithubCloner m)
type
TaskMonad Build m =
(MonadUnliftIO m, StaticPQ m, HasDockerInfo m, GithubCloner m, HasGithubStatus m)
performTask Build {..} =
bracket createDir (liftIO . removePathForcibly) $ \dir -> flip catchAny (const $ return Failure) $ do
@ -62,7 +62,7 @@ instance Task Build "build-repo" where
<> show n
<> " and error "
<> err
scheduleTask erroredTask
scheduleFailedStatus err owner repoName sha
updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
ExitSuccess -> do
h <- liftIO D.defaultHttpHandler
@ -73,7 +73,8 @@ instance Task Build "build-repo" where
Exception err,
WithLog env Message m,
StaticPQ m,
MonadUnliftIO m
MonadUnliftIO m,
HasGithubStatus m
) =>
D.DockerT IO (Either err a) ->
m a
@ -124,7 +125,7 @@ instance Task Build "build-repo" where
<> show n
<> " and error "
<> err
scheduleTask erroredTask
scheduleFailedStatus err owner repoName sha
updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
(ExitSuccess, buildOut) ->
case eitherDecode' (BS.dropWhile (/= '{') buildOut) of
@ -136,48 +137,28 @@ instance Task Build "build-repo" where
<> show sha
<> ": "
<> err
scheduleTask erroredTask
scheduleFailedStatus err owner repoName sha
updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)
Right testResult@TestResult {..} -> do
let total = M.size tests
passed = M.size . M.filter id $ tests
description = T.pack $ show passed <> "/" <> show total
status =
statusTask
NewStatus
{ newStatusState =
if total == passed then StatusSuccess else StatusFailure,
newStatusTargetUrl = Nothing,
newStatusDescription = Just description,
newStatusContext = Nothing
}
scheduleTask status
scheduleTestedStatus testResult owner repoName sha
updateSubmissionStatus fullRepoName sha' (SubmissionRun testResult)
return Success
where
statusTask = StatusUpdate owner repoName sha
erroredTask =
statusTask $
NewStatus
{ newStatusState = StatusError,
newStatusTargetUrl = Nothing,
newStatusDescription = Just "Build failed",
newStatusContext = Nothing
}
fullRepoName = T.unpack $ untagName owner <> "/" <> untagName repoName
sha' = T.unpack $ untagName sha
runEither ::
( Exception err,
WithLog env Message m,
StaticPQ m,
MonadUnliftIO m
MonadUnliftIO m,
HasGithubStatus m
) =>
Either err b ->
m b
runEither (Left err) = do
let err' = show err
logError $ T.pack err'
scheduleTask erroredTask
scheduleFailedStatus err' owner repoName sha
updateSubmissionStatus fullRepoName sha' (SubmissionFailed err')
throwIO err
runEither (Right a) = return a

1
src/Data/Tasks/StatusUpdate.hs
View File

@ -31,7 +31,6 @@ instance FromJSON NewStatus where
<*> v .:? "context"
instance Task StatusUpdate "update-commit-ci-status" where
type TaskMonad StatusUpdate m = (AppRequestable m)
performTask StatusUpdate {..} = do

72
src/Server.hs
View File

@ -10,6 +10,7 @@ import Colog
import Control.AppRequestable
import Control.Concurrent
import Control.GithubCloner
import Control.HasGithubStatus
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
@ -37,7 +38,7 @@ import GitHub.App.Request
import GitHub.Auth (Auth (OAuth))
import GitHub.Data.Name
import GitHub.Data.Webhooks.Events
import GitHub.Data.Webhooks.Payload
import GitHub.Data.Webhooks.Payload hiding (URL (..))
import Network.HTTP.Client.TLS (newTlsManager)
import Network.HTTP.Media.MediaType
import Network.Wai.Handler.Warp
@ -80,11 +81,8 @@ webhookInstallation _ ((), ev) =
print ev
hFlush stdout
pendingStatus :: NewStatus
pendingStatus = NewStatus StatusPending Nothing Nothing Nothing
webhookPushEvent ::
(StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m, MonadError ServerError m) =>
(StaticPQ m, MonadReader (ServerData m) m, MonadUnliftIO m, HasTasks m, MonadError ServerError m) =>
RepoWebhookEvent ->
((), PushEvent) ->
m ()
@ -102,7 +100,7 @@ webhookPushEvent _ ((), ev) = do
M.takeWhileAntitone (repoName >) tasks
case task of
Just (name, TaskConfig {..}) | T.take (T.length name) repoName == name -> do
scheduleTask $ StatusUpdate (N owner) (N repoName) (N sha) pendingStatus
schedulePendingStatus (N owner) (N repoName) (N sha)
createSubmission $
Submission
user
@ -117,7 +115,7 @@ webhookPushEvent _ ((), ev) = do
_ -> return ()
retestSubmission ::
(StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m, MonadHasBaseUrl m) =>
(StaticPQ m, MonadReader (ServerData m) m, MonadUnliftIO m, HasTasks m, MonadHasBaseUrl m) =>
String ->
String ->
String ->
@ -136,7 +134,7 @@ retestSubmission owner repoName sha = do
M.takeWhileAntitone (repoName' >) tasks
case task of
Just (name, TaskConfig {..}) | T.take (T.length name) repoName' == name -> do
scheduleTask $ StatusUpdate (N owner') (N repoName') (N sha') pendingStatus
schedulePendingStatus (N owner') (N repoName') (N sha')
updateSubmissionStatus fullRepoName sha BuildScheduled
scheduleTask $ Build prebuild dockerfile (N owner') (N repoName') (N sha') timeoutMinutes
_ -> return ()
@ -186,7 +184,8 @@ runServer = do
tasks = ts,
logger = cfilter ((logSeverity <=) . msgSeverity) richMessageAction,
baseUrl = baseSiteUrl,
dockerUrl = T.pack cfgDockerUrl
dockerUrl = T.pack cfgDockerUrl,
context = githubContext
}
repeatIfNotEmpty n f = f >>= \m -> do
when (m == 0) $ liftIO $ threadDelay n
@ -230,8 +229,9 @@ data ServerData m
{ githubAppAuth :: !InstallationAuth,
tasks :: IORef TasksConfig,
logger :: LogAction m Message,
baseUrl :: String,
dockerUrl :: T.Text
baseUrl :: T.Text,
dockerUrl :: T.Text,
context :: T.Text
}
newtype PolyGitHubKey = PolyGitHubKey (forall result. GitHubKey result)
@ -266,6 +266,56 @@ instance MonadReader (ServerData n) m => MonadHasBaseUrl m where
instance (MonadIO m, MonadReader (ServerData n) m) => HasTasks m where
getTasks = asks tasks >>= liftIO . readIORef
instance (MonadReader (ServerData m) m, StaticPQ m, MonadUnliftIO m) => HasGithubStatus m where
schedulePendingStatus nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do
h <- asks baseUrl
c <- asks context
scheduleTask $
StatusUpdate
nOwner
nRepo
nCommit
( NewStatus
StatusPending
(Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha)
Nothing
(Just c)
)
scheduleTestedStatus TestResult {..} nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do
h <- asks baseUrl
c <- asks context
let total = M.size tests
passed = M.size . M.filter id $ tests
description = T.pack $ show passed <> "/" <> show total
status =
StatusUpdate
nOwner
nRepo
nCommit
NewStatus
{ newStatusState =
if total == passed then StatusSuccess else StatusFailure,
newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,
newStatusDescription = Just description,
newStatusContext = Just c
}
scheduleTask status
scheduleFailedStatus _ nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do
h <- asks baseUrl
c <- asks context
let status =
StatusUpdate
nOwner
nRepo
nCommit
NewStatus
{ newStatusState = StatusError,
newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,
newStatusDescription = Just "Build failed",
newStatusContext = Just c
}
scheduleTask status
instance (MonadReader (ServerData n) m) => HasDockerInfo m where
getDockerUrl = asks dockerUrl

8
src/Server/Config.hs
View File

@ -28,11 +28,12 @@ data Config
installationId :: !(Id Installation),
tasksPath :: !FilePath,
databseUrl :: !ByteString,
baseSiteUrl :: !String,
baseSiteUrl :: !Text,
cfgDockerUrl :: !String,
cfgDockerFile :: !FilePath,
logSeverity :: !Severity,
builderCount :: !Int
builderCount :: !Int,
githubContext :: !Text
}
deriving (Show, Generic)
@ -68,7 +69,8 @@ defaultConfig =
cfgDockerUrl = "http://localhost:1234",
cfgDockerFile = "TmpDockerfile",
logSeverity = Info,
builderCount = 2
builderCount = 2,
githubContext = "MY CI NAME"
}
getConfig :: IO Config

5
src/Server/Html.hs
View File

@ -16,6 +16,7 @@ import qualified Data.Map as M
import Data.String
import Data.Submission
import Data.Submission.Query
import qualified Data.Text as T
import Server.Schema
import Squeal.PostgreSQL (Jsonb (..))
import Text.Blaze
@ -91,12 +92,12 @@ getSubmissionR user repo sha' = do
H.body inner
class MonadHasBaseUrl m where
getBaseUrl :: m String
getBaseUrl :: m T.Text
getUrl :: (MonadHasBaseUrl m, Monad m) => String -> String -> m String
getUrl fullName sha = do
siteBase <- getBaseUrl
return $ siteBase <> "/submission/" <> fullName <> "/" <> sha
return $ T.unpack siteBase <> "/submission/" <> fullName <> "/" <> sha
redirectToSubmission ::
(MonadHasBaseUrl m, Monad m) =>