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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
{-# 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 Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async, link, waitEither_)
import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO,
writeTQueue)
import qualified Data.Text as T
import Fmt ((+|), (|+))
import Handlers (AdminOverview (AdminOverview),
MapService (MapService),
relintImpl, stateImpl,
statusImpl)
import HtmlOrphans ()
import Network.HTTP.Client (defaultManagerSettings,
newManager)
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, PlainText,
Post, Raw, ReqBody,
Server, serve,
type (:<|>) (..),
type (:>))
import Servant.HTML.Lucid (HTML)
import Servant.Server.StaticFiles (serveDirectoryWebApp)
import Server (JobStatus, Org (..),
ServerState, Sha1,
emptyState, exneuland,
interval, loadConfig,
orgs, port, token,
verbose)
import Worker (Job (Job), linterThread)
import Control.Monad.Logger (logInfoN,
runStdoutLoggingT)
import Servant.API (Header)
import Servant.Client (ClientM, client,
mkClientEnv, runClientM)
type family PolyEndpoint method format payload where
PolyEndpoint Get format payload =
Get format payload
PolyEndpoint Post format payload =
Header "Auth" Text :> ReqBody format payload :> Post '[PlainText] Text
type MapServiceAPI method =
"api" :> "maps" :> "list" :> PolyEndpoint method '[JSON] MapService
-- | abstract api
type API format =
"status" :> Capture "org" Text :> Capture "jobid" Sha1 :> Get '[format] JobStatus
:<|> "status" :> Capture "org" Text :> Capture "jobid" Sha1 :> "relint" :> Post '[format] Text
:<|> "admin" :> "overview" :> Get '[format] AdminOverview
-- | actual set of routes: api for json & html + static pages from disk
type Routes = "api" :> API JSON
:<|> MapServiceAPI Get
:<|> API HTML -- websites mirror the API exactly
:<|> Raw
-- | API's implementation
jsonAPI :: forall format. TQueue Job -> MVar ServerState -> Server (API format)
jsonAPI queue state = statusImpl state
:<|> relintImpl queue state
:<|> stateImpl @AdminOverview state
-- | Complete set of routes: API + HTML sites
server :: TQueue Job -> MVar ServerState -> Server Routes
server queue state = jsonAPI @JSON queue state
:<|> stateImpl @MapService state
:<|> jsonAPI @HTML queue state
:<|> serveDirectoryWebApp "./static"
app :: TQueue Job -> MVar ServerState -> Application
app queue = serve (Proxy @Routes) . server queue
postNewMaps :: Maybe Text -> MapService -> ClientM Text
postNewMaps = client (Proxy @(MapServiceAPI Post))
main :: IO ()
main = do
config <- loadConfig "./config.toml"
state <- newMVar (emptyState config)
queue :: TQueue Job <- newTQueueIO
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)
-- TODO: what about tls / https?
whenJust (view exneuland config) $ \baseurl -> do
manager' <- newManager defaultManagerSettings
updater <- async $ runStdoutLoggingT $ forever $ do
done <- readMVar state
res <- liftIO $ runClientM
(postNewMaps (view token config) (MapService done))
(mkClientEnv manager' baseurl)
logInfoN $ "exneuland maps POST request: " <> show res
liftIO $ threadDelay (view interval config * 1000000)
link updater
-- spawns threads for each job in the queue
linter <- async $ void $ linterThread config queue state
link linter
link poker
let warpsettings =
setPort (view port config)
defaultSettings
putTextLn $ "starting server on port " <> show (view port config)
runSettings warpsettings
. loggerMiddleware
$ app queue state
waitEither_ linter poker
where
showInfo org =
"→ org "+|orgSlug org|+" ("+|length (orgRepos org)|+" repositories)\n" :: Text
|
