@@ -0,0 +1,381 @@
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