@@ -0,0 +1,256 @@
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.Monad.Except
14+import Control.Monad.IO.Unlift
15+import Control.Monad.Reader
16+import Control.Task.Scheduler
17+import Data.Aeson
18+import Data.ByteString
19+import Data.IORef
20+import Data.Map (Map)
21+import qualified Data.Map as M
22+import Data.Submission
23+import Data.Submission.Query
24+import Data.Tasks.Build
25+import Data.Tasks.StatusUpdate
26+import qualified Data.Text as T
27+import Data.Yaml
28+import GHC.Generics
29+import GitHub
30+import GitHub.App.Auth
31+import GitHub.App.Request
32+import GitHub.Data.Name
33+import GitHub.Data.Webhooks.Events
34+import GitHub.Data.Webhooks.Payload
35+import Network.Wai.Handler.Warp
36+import Servant
37+import Servant.GitHub.Webhook
38+import Servant.HTML.Blaze
39+import Server.Config
40+import Server.Html
41+import Server.Schema
42+import Squeal.PostgreSQL
43+import System.IO
44+import Text.Blaze.Html
45+import UnliftIO.Exception (try)
46+
47+type API =
48+ "github-webhook"
49+ :> ( GitHubEvent '[ 'WebhookInstallationEvent]
50+ :> GitHubSignedReqBody '[JSON] InstallationEvent
51+ :> Post '[JSON] ()
52+ :<|> GitHubEvent '[ 'WebhookPushEvent]
53+ :> GitHubSignedReqBody '[JSON] PushEvent
54+ :> Post '[JSON] ()
55+ )
56+ :<|> "submission"
57+ :> Capture "user name" String
58+ :> Capture "repo name" String
59+ :> Capture "sha" String
60+ :> Get '[HTML] Markup
61+ :<|> "submission"
62+ :> Capture "user name" String
63+ :> Capture "repo name" String
64+ :> Capture "sha" String
65+ :> "restart"
66+ :> Post '[HTML] Markup
67+
68+webhookInstallation :: MonadIO m => RepoWebhookEvent -> ((), InstallationEvent) -> m ()
69+webhookInstallation _ ((), ev) =
70+ liftIO $ do
71+ print ev
72+ hFlush stdout
73+
74+pendingStatus :: NewStatus
75+pendingStatus = NewStatus StatusPending Nothing Nothing Nothing
76+
77+webhookPushEvent ::
78+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m) =>
79+ RepoWebhookEvent ->
80+ ((), PushEvent) ->
81+ m ()
82+webhookPushEvent _ ((), ev) = do
83+ let repo = evPushRepository ev
84+ user = T.unpack . whUserLogin . evPushSender $ ev
85+ fullRepoName = whRepoFullName repo
86+ [owner, repoName] = T.splitOn "/" fullRepoName
87+ Just sha = evPushHeadSha ev
88+ tasks <- getTasks
89+ let task =
90+ M.lookupMax $
91+ M.takeWhileAntitone (repoName >) tasks
92+ case task of
93+ Just (name, TaskConfig {..}) | T.take (T.length name) repoName == name -> do
94+ scheduleTask $ StatusUpdate (N owner) (N repoName) (N sha) pendingStatus
95+ createSubmission $
96+ Submission
97+ user
98+ (T.unpack fullRepoName)
99+ (T.unpack name)
100+ (T.unpack sha)
101+ (Jsonb BuildScheduled)
102+ scheduleTask $ Build prebuild build (N owner) (N repoName) (N sha)
103+ liftIO $ do
104+ print ev
105+ hFlush stdout
106+ _ -> return ()
107+
108+retestSubmission ::
109+ (StaticPQ m, WithLog env Message m, MonadUnliftIO m, HasTasks m, MonadHasBaseUrl m) =>
110+ String ->
111+ String ->
112+ String ->
113+ m Markup
114+retestSubmission owner repoName sha = do
115+ let fullRepoName = owner <> "/" <> repoName
116+ repoName' = T.pack repoName
117+ sha' = T.pack sha
118+ owner' = T.pack owner
119+ getSubmission fullRepoName sha >>= \case
120+ Nothing -> return ()
121+ Just _ -> do
122+ tasks <- getTasks
123+ let task =
124+ M.lookupMax $
125+ M.takeWhileAntitone (repoName' >) tasks
126+ case task of
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')
131+ _ -> return ()
132+ redirectToSubmission owner repoName sha
133+
134+newtype ServerM (schema :: SchemasType) a
135+ = ServerM
136+ { unApp :: ReaderT (ServerData (ServerM schema)) (PQ schema schema IO) a
137+ }
138+ deriving newtype
139+ ( Functor,
140+ Applicative,
141+ Monad,
142+ MonadIO,
143+ MonadReader (ServerData (ServerM schema)),
144+ MonadPQ schema,
145+ MonadUnliftIO
146+ )
147+
148+server :: ServerT API (ServerM Schema)
149+server = (webhookInstallation :<|> webhookPushEvent) :<|> getSubmissionR :<|> retestSubmission
150+
151+runServer :: IO ()
152+runServer = do
153+ c@Config {..} <- getConfig
154+ print c
155+ auth <- mkInstallationAuth (AppAuth appId appPkPem) installationId
156+ ts <- newIORef mempty
157+ pool <- createConnectionPool databseUrl 1 0.5 10
158+ _ <- forkIO $ do
159+ updateTasks ts tasksPath
160+ threadDelay $ 10 * 60 * (10 ^ (6 :: Int))
161+ let context =
162+ gitPolyHubKey (return webhookSecret)
163+ :. EmptyContext
164+ serverData = ServerData
165+ { githubAppAuth = auth,
166+ githubUserName = GithubUserName githubUsername,
167+ githubAccessToken = GithubAccessToken personalAccessToken,
168+ tasks = ts,
169+ logger = simpleMessageAction,
170+ baseUrl = baseSiteUrl
171+ }
172+ repeatIfNotEmpty n f = f >>= \m -> do
173+ when (m == 0) $ liftIO $ threadDelay n
174+ repeatIfNotEmpty n f
175+ _ <-
176+ forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))
177+ . usingConnectionPool pool
178+ . (`runReaderT` serverData)
179+ . unApp
180+ $ runTasks @'[Build] 1
181+ _ <-
182+ forkIO . repeatIfNotEmpty (10 ^ (6 :: Int))
183+ . usingConnectionPool pool
184+ . (`runReaderT` serverData)
185+ . unApp
186+ $ runTasks @'[StatusUpdate] 5
187+ run port $ serveWithContext (Proxy @API) context $
188+ hoistServerWithContext
189+ (Proxy @API)
190+ (Proxy @'[PolyGitHubKey])
191+ (Handler . ExceptT . try . usingConnectionPool pool . (`runReaderT` serverData) . unApp)
192+ server
193+
194+updateTasks :: IORef TasksConfig -> FilePath -> IO ()
195+updateTasks ref path =
196+ decodeFileEither path >>= \case
197+ Right a -> writeIORef ref a
198+ Left e -> print e
199+
200+data ServerData m
201+ = ServerData
202+ { githubAppAuth :: !InstallationAuth,
203+ githubUserName :: !GithubUserName,
204+ githubAccessToken :: !GithubAccessToken,
205+ tasks :: IORef TasksConfig,
206+ logger :: LogAction m Message,
207+ baseUrl :: String
208+ }
209+
210+newtype PolyGitHubKey = PolyGitHubKey (forall result. GitHubKey result)
211+
212+gitPolyHubKey :: IO ByteString -> PolyGitHubKey
213+gitPolyHubKey k = PolyGitHubKey (Servant.GitHub.Webhook.gitHubKey k)
214+
215+instance HasContextEntry '[PolyGitHubKey] (GitHubKey result) where
216+ getContextEntry (PolyGitHubKey x :. _) = x
217+
218+instance MonadReader (ServerData n) m => GithubCloner m where
219+
220+ getGithubAccessToken = asks githubAccessToken
221+
222+ getGithubUserName = asks githubUserName
223+
224+instance (MonadIO m, MonadReader (ServerData n) m) => AppRequestable m where
225+ appRequest req = do
226+ auth <- asks githubAppAuth
227+ liftIO $ executeAppRequest auth req
228+
229+instance MonadReader (ServerData n) m => MonadHasBaseUrl m where
230+ getBaseUrl = asks baseUrl
231+
232+instance (MonadIO m, MonadReader (ServerData n) m) => HasTasks m where
233+ getTasks = asks tasks >>= liftIO . readIORef
234+
235+type TasksConfig = Map T.Text TaskConfig
236+
237+data TaskConfig
238+ = TaskConfig
239+ { prebuild :: String,
240+ build :: String
241+ }
242+ deriving stock (Show, Eq, Generic)
243+ deriving anyclass (FromJSON, ToJSON)
244+
245+class HasTasks m where
246+ getTasks :: m TasksConfig
247+
248+instance HasLog (ServerData m) Message m where
249+
250+ getLogAction :: ServerData m -> LogAction m Message
251+ getLogAction = logger
252+ {-# INLINE getLogAction #-}
253+
254+ setLogAction :: LogAction m Message -> ServerData m -> ServerData m
255+ setLogAction newLogAction env = env {logger = newLogAction}
256+ {-# INLINE setLogAction #-}