0b85829 · sc-build · git.iko.soy

git.iko.soy/sc-build

on master help sign in

docker seems to work

0b85829iko7 years ago

package.yaml+3

compare with master

unifiedsplit

@@ -46,6 +46,9 @@ library:

46 - blaze-markup

47 - blaze-html

48 - clay

49+ - docker

50+ - exceptions

51+ - transformers

50executables:

53executables:

51 sc-build-exe:

54 sc-build-exe:

sc-build.cabal+4−1

@@ -4,7 +4,7 @@ cabal-version: 1.12

4--

5-- see: https://github.com/sol/hpack

6--

7−-- hash: bb953e6231fcc3939bfe085afcd3e792cbc40462461bbe4fb82ae69f1796be4c

7+-- hash: 56eccc7f4958f234614ddcff75d3b965ad9a29747591e1e71b73d56faaf48d1c

9name: sc-build

10version: 0.1.0.0

@@ -52,6 +52,8 @@ library

52 , containers

53 , cryptonite

54 , directory

55+ , docker

56+ , exceptions

55 , generics-sop

57 , generics-sop

56 , github

58 , github

57 , github-app

59 , github-app

@@ -66,6 +68,7 @@ library

66 , squeal-postgresql

68 , squeal-postgresql

67 , text

69 , text

68 , time

70 , time

71+ , transformers

69 , typed-process

72 , typed-process

70 , unliftio

73 , unliftio

71 , unliftio-core

74 , unliftio-core

src/Data/Tasks/Build.hs+50−12

@@ -3,12 +3,13 @@

4module Data.Tasks.Build

5 ( Build (..),

6+ HasDockerInfo (..),

6 )

7 )

7where

8where

9import Colog

10import Colog

10import Control.GithubCloner

11import Control.GithubCloner

11−import Control.Monad.IO.Class

12+import Control.Monad.Except

12import Control.Monad.IO.Unlift

13import Control.Monad.IO.Unlift

13import Control.Task

14import Control.Task

14import Control.Task.Scheduler

15import Control.Task.Scheduler

@@ -21,6 +22,7 @@ import Data.Submission.Query

21import Data.Tasks.StatusUpdate

22import Data.Tasks.StatusUpdate

22import qualified Data.Text as T

23import qualified Data.Text as T

23import Data.Time.Clock.POSIX

24import Data.Time.Clock.POSIX

25+import qualified Docker.Client as D

24import GHC.Generics

26import GHC.Generics

25import GitHub

27import GitHub

26import Server.Schema

28import Server.Schema

@@ -33,7 +35,7 @@ import UnliftIO.Exception

33data Build

35data Build

34 = Build

36 = Build

35 { preProcessShell :: String,

37 { preProcessShell :: String,

36− buildCommand :: String,

38+ dockerFile :: String,

37 owner :: Name Owner,

39 owner :: Name Owner,

38 repoName :: Name Repo,

40 repoName :: Name Repo,

39 sha :: Name Commit

41 sha :: Name Commit

@@ -42,7 +44,7 @@ data Build

43instance Task Build "build-repo" where

45instance Task Build "build-repo" where

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

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

47 performTask Build {..} =

49 performTask Build {..} =

48 bracket createDir (liftIO . removePathForcibly) $ \dir -> do

50 bracket createDir (liftIO . removePathForcibly) $ \dir -> do

@@ -63,10 +65,38 @@ instance Task Build "build-repo" where

63 scheduleTask erroredTask

65 scheduleTask erroredTask

64 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

66 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

65 ExitSuccess -> do

67 ExitSuccess -> do

66− (buildCode, buildOut, buildErr) <- readProcess . setWorkingDir dir . fromString $ buildCommand

68+ h <- liftIO D.defaultHttpHandler

69+ dUrl <- getDockerUrl

70+ let opts = D.defaultCreateOpts imageName

71+ runDocker :: forall a m. MonadIO m => D.DockerT IO a -> m a

72+ runDocker = liftIO . D.runDockerT (D.defaultClientOpts {D.baseUrl = dUrl}, h)

73+ imageName = T.pack dir

74+ liftIO $ writeFile (dir <> "/Dockerfile") dockerFile

75+ absDir <- liftIO $ makeAbsolute dir

76+ let waitDockerForever cid =

77+ D.waitContainer cid >>= \case

78+ Left D.GenericDockerError {} -> waitDockerForever cid

79+ a -> return a

80+ dockerRes <- runDocker . runExceptT $ do

81+ ExceptT $ D.buildImageFromDockerfile (D.defaultBuildOpts imageName) absDir

82+ cid <- ExceptT $ D.createContainer opts Nothing

83+ ExceptT $ D.startContainer D.defaultStartOpts cid

84+ buildCode <- ExceptT $ waitDockerForever cid

85+ buildOut <-

86+ ExceptT $

87+ D.getContainerLogs

88+ D.LogOpts

89+ { stdout = True,

90+ stderr = False,

91+ since = Nothing,

92+ timestamps = False,

93+ tail = D.All

94+ }

95+ cid

96+ return (buildCode, buildOut)

67− case buildCode of

97+ case dockerRes of

68− ExitFailure n -> do

98+ Right (ExitFailure n, buildOut) -> do

69− let err = BS.unpack buildErr

99+ let err = BS.unpack buildOut

70 logError . T.pack $

100 logError . T.pack $

71 "test command for repo " <> show fullRepoName <> " at sha "

101 "test command for repo " <> show fullRepoName <> " at sha "

72 <> show sha

102 <> show sha

@@ -76,10 +106,15 @@ instance Task Build "build-repo" where

76 <> err

106 <> err

77 scheduleTask erroredTask

107 scheduleTask erroredTask

78 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

108 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

109+ Left err' -> do

110+ let err = show err'

111+ logError . T.pack $ err

112+ scheduleTask erroredTask

113+ updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

79− ExitSuccess ->

114+ Right (ExitSuccess, buildOut) ->

80− case decode buildOut of

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

81− Nothing -> do

116+ Left err' -> do

82− let err = BS.unpack buildOut

117+ let err = err' <> " " <> BS.unpack buildOut

83 logError . T.pack $

118 logError . T.pack $

84 "could not decode test result from repo " <> show fullRepoName

119 "could not decode test result from repo " <> show fullRepoName

85 <> " at sha "

120 <> " at sha "

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

88 <> err

123 <> err

89 scheduleTask erroredTask

124 scheduleTask erroredTask

90 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

125 updateSubmissionStatus fullRepoName sha' (SubmissionFailed err)

91− Just testResult@TestResult {..} -> do

126+ Right testResult@TestResult {..} -> do

92 let total = M.size tests

127 let total = M.size tests

93 passed = M.size . M.filter id $ tests

128 passed = M.size . M.filter id $ tests

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

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

@@ -131,3 +166,6 @@ getTmpDirName = liftIO $ do

131 time :: Integer <- round <$> getPOSIXTime

166 time :: Integer <- round <$> getPOSIXTime

132 i <- randomIO @Int

167 i <- randomIO @Int

133 return $ show time <> "-" <> show i

168 return $ show time <> "-" <> show i

169+

170+class HasDockerInfo m where

171+ getDockerUrl :: m T.Text

src/Server.hs+12−6

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

99 (T.unpack name)

100 (T.unpack sha)

101 (Jsonb BuildScheduled)

102− scheduleTask $ Build prebuild build (N owner) (N repoName) (N sha)

102+ scheduleTask $ Build prebuild dockerfile (N owner) (N repoName) (N sha)

103 liftIO $ do

104 print ev

105 hFlush stdout

@@ -127,7 +127,7 @@ retestSubmission owner repoName sha = do

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

128 scheduleTask $ StatusUpdate (N owner') (N repoName') (N sha') pendingStatus

129 updateSubmissionStatus fullRepoName sha BuildScheduled

130− scheduleTask $ Build prebuild build (N owner') (N repoName') (N sha')

130+ scheduleTask $ Build prebuild dockerfile (N owner') (N repoName') (N sha')

131 _ -> return ()

132 redirectToSubmission owner repoName sha

133

@@ -157,7 +157,7 @@ runServer = do

157 pool <- createConnectionPool databseUrl 1 0.5 10

158 _ <- forkIO $ do

159 updateTasks ts tasksPath

160− threadDelay $ 10 * 60 * (10 ^ (6 :: Int))

160+ threadDelay $ 5 * 60 * (10 ^ (6 :: Int))

161 let context =

162 gitPolyHubKey (return webhookSecret)

163 :. EmptyContext

@@ -167,7 +167,8 @@ runServer = do

167 githubAccessToken = GithubAccessToken personalAccessToken,

168 tasks = ts,

169 logger = simpleMessageAction,

170− baseUrl = baseSiteUrl

170+ baseUrl = baseSiteUrl,

171+ dockerUrl = T.pack cfgDockerUrl

171 }

172 }

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

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

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

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

@@ -204,7 +205,8 @@ data ServerData m

204 githubAccessToken :: !GithubAccessToken,

205 githubAccessToken :: !GithubAccessToken,

205 tasks :: IORef TasksConfig,

206 tasks :: IORef TasksConfig,

206 logger :: LogAction m Message,

207 logger :: LogAction m Message,

207− baseUrl :: String

208+ baseUrl :: String,

209+ dockerUrl :: T.Text

208 }

210 }

209

211

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

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

@@ -232,12 +234,16 @@ instance MonadReader (ServerData n) m => MonadHasBaseUrl m where

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

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

233 getTasks = asks tasks >>= liftIO . readIORef

235 getTasks = asks tasks >>= liftIO . readIORef

234

236

237+instance (MonadReader (ServerData n) m) => HasDockerInfo m where

238+ getDockerUrl = asks dockerUrl

239+

235type TasksConfig = Map T.Text TaskConfig

240type TasksConfig = Map T.Text TaskConfig

236

241

237data TaskConfig

242data TaskConfig

238 = TaskConfig

243 = TaskConfig

239 { prebuild :: String,

244 { prebuild :: String,

245+ dockerfile :: String

240− build :: String

246+ -- build :: T.Text

241 }

247 }

242 deriving stock (Show, Eq, Generic)

248 deriving stock (Show, Eq, Generic)

243 deriving anyclass (FromJSON, ToJSON)

249 deriving anyclass (FromJSON, ToJSON)

src/Server/Config.hs+5−1

@@ -27,7 +27,9 @@ data Config

27 githubUsername :: !String,

28 tasksPath :: !FilePath,

29 databseUrl :: !ByteString,

30− baseSiteUrl :: !String

30+ baseSiteUrl :: !String,

31+ cfgDockerUrl :: !String,

32+ cfgDockerFile :: !FilePath

31 }

33 }

32 deriving (Show)

34 deriving (Show)

@@ -44,6 +46,8 @@ getConfig =

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

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

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

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

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

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

49+ <*> (fromMaybe "http://localhost:1234" <$> lookupEnv "DOCKER_URL")

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

47 where

51 where

48 readPem :: IO PrivateKey

52 readPem :: IO PrivateKey

49 readPem = do

53 readPem = do

stack.yaml+2

@@ -46,6 +46,8 @@ extra-deps:

46- git: https://github.com/ilyakooo0/github-app

47 commit: 0bede85ab53eb8f953cf6f4e58a756a205e88e0b

48- servant-github-webhook-0.4.2.0

49+- docker-0.6.0.2

50+- http-client-0.5.14

50# Override default flag values for local packages and extra-deps

52# Override default flag values for local packages and extra-deps

51# flags: {}

53# flags: {}

tasks.yamlnew file+10

@@ -0,0 +1,10 @@

1+test-task:

2+ prebuild: |

3+ cp -f ../../test-task/package.yaml .

4+ cp -f ../../test-task/stack.yaml .

5+ cp -f -R ../../test-task/test .

6+ dockerfile: |

7+ FROM fast-lts-14.20

8+ COPY . src

9+ WORKDIR /src

10+ ENTRYPOINT stack test --fast