1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- | simple server offering linting "as a service"
module Main where
import Universum
import Cli.Extras (mkDefaultCliConfig)
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async, waitEither_)
import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO,
writeTQueue)
import qualified Data.Text as T
import Fmt ((+|), (|+))
import Handlers (AdminOverview,
adminOverviewImpl,
statusImpl)
import HtmlOrphans ()
import Network.Wai.Handler.Warp (defaultSettings,
runSettings, setPort)
import Network.Wai.Middleware.Gzip (def)
import Network.Wai.Middleware.RequestLogger (OutputFormat (..),
RequestLoggerSettings (..),
mkRequestLogger)
import Servant (Application, Capture,
Get, JSON, Raw, Server,
serve, type (:<|>) (..),
type (:>))
import Servant.HTML.Lucid (HTML)
import Servant.Server.StaticFiles (serveDirectoryWebApp)
import Server (JobStatus, Org (..),
ServerState, Sha1,
defaultState, interval,
loadConfig, orgs, port,
verbose)
import Worker (Job (Job), linterThread)
-- | Main API type
type API format =
-- "submit" :> ReqBody '[JSON] RemoteRef :> Post '[format] UUID
"status" :> Capture "jobid" Sha1 :> Get '[format] JobStatus
-- :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent
:<|> "admin" :> "overview" :> Get '[format] AdminOverview
type Routes = "api" :> API JSON
:<|> API HTML -- websites mirror the API exactly
:<|> Raw
-- | API's implementation
jsonAPI :: forall format. MVar ServerState -> Server (API format)
jsonAPI state = statusImpl state
:<|> adminOverviewImpl state
-- | Complete set of routes: API + HTML sites
server :: MVar ServerState -> Server Routes
server state = jsonAPI @JSON state
:<|> jsonAPI @HTML state
:<|> serveDirectoryWebApp "./static"
app :: MVar ServerState -> Application
app = serve (Proxy @Routes) . server
main :: IO ()
main = do
config <- loadConfig "./config.toml"
state <- newMVar defaultState
queue :: TQueue Job <- newTQueueIO
-- TODO: i really don't like all this cli logging stuff, replace it with
-- fast-logger at some point …
cliconfig <- liftIO $ mkDefaultCliConfig ["-v" | view verbose config]
loggerMiddleware <- mkRequestLogger
$ def { outputFormat = Detailed (view verbose config) }
putTextLn "reading config …"
putTextLn $ T.concat $ map showInfo (view orgs config)
-- periodically ‘pokes’ jobs to re-lint each repo
poker <- async $ forever $ do
atomically $ forM_ (view orgs config) $ \org ->
forM_ (orgRepos org) $ \repo ->
writeTQueue queue (Job repo org)
-- microseconds for some reason
threadDelay (view interval config * 1000000)
-- spawns threads for each job in the queue
linter <- async $ void $ linterThread config cliconfig queue state
let warpsettings =
setPort (view port config)
defaultSettings
runSettings warpsettings
. loggerMiddleware
$ app state
waitEither_ linter poker
where
showInfo org =
"→ org "+|orgSlug org|+" divoc ("+|length (orgRepos org)|+" repositoryies)\n" :: Text
|
