@@ -1,381 +0,0 @@
1−{-# LANGUAGE TypeApplications #-}
2−{-# OPTIONS_GHC -Wno-orphans #-}
3−
4−module Server
5− ( runServer,
6− )
7−where
8−
9−import Colog
10−import Control.AppRequestable
11−import Control.Concurrent
12−import Control.GithubCloner
13−import Control.HasGithubStatus
14−import Control.Monad.Except
15−import Control.Monad.IO.Unlift
16−import Control.Monad.Reader
17−import Control.Task.Scheduler
18−import Crypto.PubKey.RSA.Read
19−import Data.Aeson
20−import Data.ByteString
21−import qualified Data.ByteString as BS
22−import qualified Data.ByteString.Char8 as BSC
23−import qualified Data.ByteString.Lazy.Char8 as BSCL
24−import qualified Data.Csv as Csv
25−import Data.IORef
26−import Data.Map (Map)
27−import qualified Data.Map as M
28−import Data.Submission
29−import Data.Submission.Query
30−import Data.Tasks.Build
31−import Data.Tasks.StatusUpdate
32−import qualified Data.Text as T
33−import Data.Time.Clock
34−import Data.Yaml
35−import GHC.Generics
36−import GitHub hiding (Accept)
37−import GitHub.App.Auth
38−import GitHub.App.Request
39−import GitHub.Auth (Auth (OAuth))
40−import GitHub.Data.Name
41−import GitHub.Data.Webhooks.Events
42−import GitHub.Data.Webhooks.Payload hiding (URL (..))
43−import Network.HTTP.Client.TLS (newTlsManager)
44−import Network.HTTP.Media.MediaType
45−import Network.Wai.Handler.Warp
46−import Servant
47−import Servant.GitHub.Webhook
48−import Servant.HTML.Blaze
49−import Server.Config
50−import Server.Html
51−import Server.Schema
52−import Squeal.PostgreSQL
53−import Text.Blaze.Html
54−import UnliftIO.Exception (catch, displayException, handleAny, throwIO, try)
55−
56−type API =
57− "github-webhook"
58− :> ( GitHubEvent '[ 'WebhookInstallationEvent]
59− :> GitHubSignedReqBody '[JSON] InstallationEvent
60− :> Post '[JSON] ()
61− :<|> GitHubEvent '[ 'WebhookPushEvent]
62− :> GitHubSignedReqBody '[JSON] PushEvent
63− :> Post '[JSON] ()
64− )
65− :<|> "submission"
66− :> Capture "user name" String
67− :> Capture "repo name" String
68− :> Capture "sha" String
69− :> Get '[HTML] Markup
70− :<|> "submission"
71− :> Capture "user name" String
72− :> Capture "repo name" String
73− :> Capture "sha" String
74− :> "restart"
75− :> Post '[HTML] Markup
76− :<|> "results" :> Capture "task name" String :> Get '[CSV, HTML] [Score]
77−
78−webhookInstallation :: WithLog env Message m => RepoWebhookEvent -> ((), InstallationEvent) -> m ()
79−webhookInstallation _ ((), ev) =
80− logInfo . T.pack . show $ ev
81−
82−webhookPushEvent ::
83− ( StaticPQ m,
84− MonadReader (ServerData m) m,
85− MonadUnliftIO m,
86− HasTasks m,
87− MonadError ServerError m,
88− WithLog env Message m
89− ) =>
90− RepoWebhookEvent ->
91− ((), PushEvent) ->
92− m ()
93−webhookPushEvent _ ((), ev) = do
94− let repo = evPushRepository ev
95− user = T.unpack . whUserLogin . evPushSender $ ev
96− fullRepoName = whRepoFullName repo
97− (owner, repoName) <- case T.splitOn "/" fullRepoName of
98− [a, b] -> return (a, b)
99− _ -> throwError err422
100− sha <- maybe (throwError err422) return $ evPushHeadSha ev
101− tasks <- getTasks
102− let task =
103− M.lookupMax $
104− M.takeWhileAntitone (repoName >) tasks
105− case task of
106− Just (name, TaskConfig {..}) | T.take (T.length name) repoName == name -> do
107− nowTime <- liftIO getCurrentTime
108− if nowTime > deadline
109− then do
110− deadlineHasPassedStatus (N owner) (N repoName) (N sha)
111− createSubmission $
112− Submission
113− user
114− (T.unpack fullRepoName)
115− (T.unpack name)
116− (T.unpack sha)
117− (Jsonb PastDeadline)
118− else do
119− schedulePendingStatus (N owner) (N repoName) (N sha)
120− createSubmission $
121− Submission
122− user
123− (T.unpack fullRepoName)
124− (T.unpack name)
125− (T.unpack sha)
126− (Jsonb BuildScheduled)
127− scheduleTask $ Build prebuild dockerfile (N owner) (N repoName) (N sha) timeoutMinutes
128− logInfo . T.pack . show $ ev
129− _ -> return ()
130−
131−retestSubmission ::
132− (StaticPQ m, MonadReader (ServerData m) m, MonadUnliftIO m, HasTasks m, MonadHasBaseUrl m) =>
133− String ->
134− String ->
135− String ->
136− m Markup
137−retestSubmission owner repoName sha = do
138− let fullRepoName = owner <> "/" <> repoName
139− repoName' = T.pack repoName
140− sha' = T.pack sha
141− owner' = T.pack owner
142− getSubmission fullRepoName sha >>= \case
143− Nothing -> return ()
144− Just _ -> do
145− tasks <- getTasks
146− let task =
147− M.lookupMax $
148− M.takeWhileAntitone (repoName' >) tasks
149− case task of
150− Just (name, TaskConfig {..}) | T.take (T.length name) repoName' == name -> do
151− schedulePendingStatus (N owner') (N repoName') (N sha')
152− updateSubmissionStatus fullRepoName sha BuildScheduled
153− scheduleTask $ Build prebuild dockerfile (N owner') (N repoName') (N sha') timeoutMinutes
154− _ -> return ()
155− redirectToSubmission owner repoName sha
156−
157−newtype ServerM (schema :: SchemasType) a
158− = ServerM
159− { unApp :: ReaderT (ServerData (ServerM schema)) (PQ schema schema IO) a
160− }
161− deriving newtype
162− ( Functor,
163− Applicative,
164− Monad,
165− MonadIO,
166− MonadReader (ServerData (ServerM schema)),
167− MonadPQ schema,
168− MonadUnliftIO
169− )
170−
171−instance MonadError ServerError (ServerM schema) where
172− throwError = throwIO
173− catchError = catch
174−
175−server :: ServerT API (ServerM Schema)
176−server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission :<|> getResults
177−
178−runServer :: FilePath -> IO ()
179−runServer config = do
180− c@Config {..} <- getConfig config
181− print c
182− pem <- BS.readFile appPkPemPath
183− appPkPem <- case readRsaPem pem of
184− Right k -> return k
185− Left e -> error (show e)
186− auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId
187− ts <- newIORef mempty
188− pool <- createConnectionPool databseUrl 1 0.5 10
189− _ <- forkIO $ do
190− updateTasks ts tasksPath
191− threadDelay $ 5 * 60 * (10 ^ (6 :: Int))
192− let context =
193− gitPolyHubKey (return webhookSecret)
194− :. EmptyContext
195− serverData =
196− ServerData
197− { githubAppAuth = auth,
198− tasks = ts,
199− logger = cfilter ((logSeverity <=) . msgSeverity) richMessageAction,
200− baseUrl = baseSiteUrl,
201− dockerUrl = T.pack cfgDockerUrl,
202− context = githubContext
203− }
204− repeatIfNotEmpty n f = f >>= \m -> do
205− when (m == 0) $ liftIO $ threadDelay n
206− repeatIfNotEmpty n f
207− printingErrors =
208− handleAny (logError . T.pack . displayException >=> const (return 0))
209− usingConnectionPool pool
210− . (`runReaderT` serverData)
211− . unApp
212− . handleAny (error . displayException)
213− $ makeAllRunnable
214− replicateM_ builderCount
215− $ forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))
216− . usingConnectionPool pool
217− . (`runReaderT` serverData)
218− . unApp
219− . printingErrors
220− $ runTasks @'[Build] 1
221− _ <-
222− forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))
223− . usingConnectionPool pool
224− . (`runReaderT` serverData)
225− . unApp
226− . printingErrors
227− $ runTasks @'[StatusUpdate] 5
228− run port $ serveWithContext (Proxy @API) context $
229− hoistServerWithContext
230− (Proxy @API)
231− (Proxy @'[PolyGitHubKey])
232− (Handler . ExceptT . try . usingConnectionPool pool . (`runReaderT` serverData) . unApp)
233− server
234−
235−updateTasks :: IORef TasksConfig -> FilePath -> IO ()
236−updateTasks ref path =
237− decodeFileEither path >>= \case
238− Right a -> writeIORef ref a
239− Left e -> print e
240−
241−data ServerData m
242− = ServerData
243− { githubAppAuth :: !InstallationAuth,
244− tasks :: IORef TasksConfig,
245− logger :: LogAction m Message,
246− baseUrl :: T.Text,
247− dockerUrl :: T.Text,
248− context :: T.Text
249− }
250−
251−newtype PolyGitHubKey = PolyGitHubKey (forall result. GitHubKey result)
252−
253−gitPolyHubKey :: IO ByteString -> PolyGitHubKey
254−gitPolyHubKey k = PolyGitHubKey (Servant.GitHub.Webhook.gitHubKey k)
255−
256−instance HasContextEntry '[PolyGitHubKey] (GitHubKey result) where
257− getContextEntry (PolyGitHubKey x :. _) = x
258−
259−instance (MonadReader (ServerData n) m, MonadIO m, MonadError ServerError m) => GithubCloner m where
260− getGithubInstallationToken =
261− either
262− (\e -> throwError err500 {errBody = BSCL.pack . displayException $ e})
263− return
264− <=< runExceptT
265− $ do
266− iAuth <- asks githubAppAuth
267− manager <- newTlsManager
268− liftIO (obtainAccessToken manager iAuth) >>= either throwError return >>= \case
269− OAuth token -> return $ InstallationToken (BSC.unpack token)
270− _ -> throwError $ UserError "Not OAuth token. This should never happen."
271−
272−instance (MonadIO m, MonadReader (ServerData n) m) => AppRequestable m where
273− appRequest req = do
274− auth <- asks githubAppAuth
275− liftIO $ executeAppRequest auth req
276−
277−instance MonadReader (ServerData n) m => MonadHasBaseUrl m where
278− getBaseUrl = asks baseUrl
279−
280−instance (MonadIO m, MonadReader (ServerData n) m) => HasTasks m where
281− getTasks = asks tasks >>= liftIO . readIORef
282−
283−instance (MonadReader (ServerData m) m, StaticPQ m, MonadUnliftIO m) => HasGithubStatus m where
284− schedulePendingStatus nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do
285− h <- asks baseUrl
286− c <- asks context
287− scheduleTask $
288− StatusUpdate
289− nOwner
290− nRepo
291− nCommit
292− ( NewStatus
293− StatusPending
294− (Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha)
295− (Just "⌛")
296− (Just c)
297− )
298− scheduleTestedStatus TestResult {..} nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do
299− h <- asks baseUrl
300− c <- asks context
301− let total = M.size tests
302− passed = M.size . M.filter id $ tests
303− description = T.pack $ show passed <> "/" <> show total <> if passed == total then " ✅" else " ❌"
304− status =
305− StatusUpdate
306− nOwner
307− nRepo
308− nCommit
309− NewStatus
310− { newStatusState =
311− if total == passed then StatusSuccess else StatusFailure,
312− newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,
313− newStatusDescription = Just description,
314− newStatusContext = Just c
315− }
316− scheduleTask status
317− scheduleFailedStatus _ nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do
318− h <- asks baseUrl
319− c <- asks context
320− let status =
321− StatusUpdate
322− nOwner
323− nRepo
324− nCommit
325− NewStatus
326− { newStatusState = StatusError,
327− newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,
328− newStatusDescription = Just "Build failed ☠️",
329− newStatusContext = Just c
330− }
331− scheduleTask status
332− deadlineHasPassedStatus nOwner@(N owner) nRepo@(N repo) nCommit@(N sha) = do
333− h <- asks baseUrl
334− c <- asks context
335− let status =
336− StatusUpdate
337− nOwner
338− nRepo
339− nCommit
340− NewStatus
341− { newStatusState = StatusError,
342− newStatusTargetUrl = Just . URL $ h <> "/submission/" <> owner <> "/" <> repo <> "/" <> sha,
343− newStatusDescription = Just "The deadline has passed ⏰",
344− newStatusContext = Just c
345− }
346− scheduleTask status
347−
348−instance (MonadReader (ServerData n) m) => HasDockerInfo m where
349− getDockerUrl = asks dockerUrl
350−
351−type TasksConfig = Map T.Text TaskConfig
352−
353−data TaskConfig
354− = TaskConfig
355− { prebuild :: String,
356− dockerfile :: String,
357− timeoutMinutes :: Int,
358− deadline :: UTCTime
359− }
360− deriving stock (Show, Eq, Generic)
361− deriving anyclass (FromJSON, ToJSON)
362−
363−class HasTasks m where
364− getTasks :: m TasksConfig
365−
366−instance HasLog (ServerData m) Message m where
367− getLogAction :: ServerData m -> LogAction m Message
368− getLogAction = logger
369− {-# INLINE getLogAction #-}
370−
371− setLogAction :: LogAction m Message -> ServerData m -> ServerData m
372− setLogAction newLogAction env = env {logger = newLogAction}
373− {-# INLINE setLogAction #-}
374−
375−data CSV
376−
377−instance Accept CSV where
378− contentType Proxy = "text" // "csv"
379−
380−instance Csv.ToRecord a => MimeRender CSV [a] where
381− mimeRender Proxy = Csv.encode